3063 lines
115 KiB
Common Lisp
3063 lines
115 KiB
Common Lisp
;-*- syntax:COMMON-LISP; Package: (OSS CL 1000) -*-
|
||
|
||
;;; DRC, March 30, 1988: Changed PROCESS-TOP to COPY-TREE
|
||
;;; the user's code so that its not bashed. This is particularly important
|
||
;;; in a resident-code environment (like XCL).
|
||
;;; AMD March 30, 1988: Changed Rlist to take advantage or RPLCONS instead of
|
||
;;; doing pushes follwed by NREVERSE.
|
||
;;; DRC, March 24, 1988: defstruct's for SYM & FRAG hacked to work in Lyric XCL
|
||
|
||
;;; (removed 2/11/2022) patch some bugs in Lyric XCL
|
||
;; #+Xerox
|
||
;; (eval-when (compile load eval)
|
||
;; (il:filesload "OSS-LYRIC-PATCHES.DFASL"))
|
||
|
||
;Anyone who wishes to, is free to use this software. However, such use
|
||
;is at the user's own risk. In particular, the system comes "as is"
|
||
;with no responsibility whatever on the part of the author or MIT.
|
||
;In addition, the following requirements must be met.
|
||
; First, the copyright notices must not be removed from this file.
|
||
; Second, if the software is redistributed to other people, proper
|
||
; credit must be given to the author.
|
||
; Third, adapting the file to run on a particular Common Lisp may
|
||
; require minor changes. However, the functionality must remain
|
||
; consistent with the documentation in MIT/AIM-958a and MIT/AIM-959a.
|
||
; (If you want a different functionality, write a new system and call
|
||
; it something else.)
|
||
|
||
;------------------------------------------------------------------------ ;
|
||
; Copyright (c) Richard C. Waters, 1988 ;
|
||
;------------------------------------------------------------------------ ;
|
||
|
||
;This file implements efficient computation with obviously synchronizable
|
||
;series expressions. All bug reports should be sent to DICK@AI.AI.MIT.EDU.
|
||
;At the author's sole descretion, bugs may or may not be fixed.
|
||
;Howevr, bug messages are very much appreciated. The functions
|
||
;in this file are documented fully in MIT/AIM-958a and MIT/AIM-959a.
|
||
;(Memo MIT/AIM-958a is an upwardly compatible, slightly revised version of
|
||
;MIT/AIM-958. The only important difference is that when an expression
|
||
;violates the restrictions, it is automatically fixed rather than just
|
||
;flagged as an error. Memo MIT/AIM-959a is identical to MIT/AIM-959
|
||
;except for fixing a few minor errors in the document.)
|
||
|
||
;This file attempts to be as compatible with pure Common Lisp as possible.
|
||
;It has been tested on the following Common Lisps to date (3/23/88).
|
||
; Symbolics CL version 7 (does not work in version 6),
|
||
; FRANZ {Allegro} CL on a Sun, LUCID CL on a Sun, DEC CL on a VAX,
|
||
; Xerox CL, Golden CL on a PC, Coral Allegro CL on a Mac.
|
||
;The companion file OSSTST LISP contains a set of regression tests for OSS.
|
||
;You should run these tests after the first time you compile OSS on a
|
||
;new system. Time permitting, I will be glad to help with any
|
||
;transportabilty problems.
|
||
|
||
#+lispm(use-package "CL")
|
||
(in-package "OSS")
|
||
|
||
(export
|
||
'(letS letS* lambdaS funcallS prognS defunS valS pass-valS alterS mapS
|
||
showS defun-primitiveS lambda-primitiveS terminateS next-inS next-outS
|
||
prologS epilogS wrapS alterableS oss-tutorial-mode
|
||
Eoss Eup Edown Esublists Elist Etree Efringe Evector Esequence
|
||
Efile Ehash Ealist Eplist Esymbols EnumerateF Enumerate-inclusiveF
|
||
Tprevious Tlatch Tuntil TuntilF Tcotruncate TmapF TscanF
|
||
Tremove-duplicates Tchunk Twindow Tpositions Tselect TselectF Tlastp
|
||
Texpand Tmask Tsubseries Tmerge Tconcatenate TconcatenateF Tsplit TsplitF
|
||
Rlist Rbag Rappend Rnconc Rvector Rfile Ralist Rplist Rhash
|
||
Rlast Rlength Rsum Rmax Rmin ReduceF
|
||
Rfirst Rnth Rand Ror Rfirst-late Rnth-late Rand-late Ror-late
|
||
*permit-non-terminating-oss-expressions*
|
||
*last-oss-loop* *last-oss-error*))
|
||
|
||
(defvar *last-oss-loop* nil "loop most recently created by OSS")
|
||
(defvar *last-oss-error* nil "info about error found most recently by OSS")
|
||
(defparameter *permit-non-terminating-oss-expressions* nil
|
||
"controls error reports for non-terminating OSS expressions")
|
||
|
||
;The key internal form is an entity called a frag (short for fragment).
|
||
|
||
(defstruct (frag (:conc-name nil) (:type list) #+Xerox(:predicate frag-p-internal) :named)
|
||
(code :?) ;the surface code corresponding to this (for error messages)
|
||
(marks 0) ;mark bits used in sweeps over a graph
|
||
(args nil) ;a list of sym structs for the args of the frag
|
||
(rets nil) ;a list of sym structs for the return vals of the frag
|
||
(aux nil) ;the auxiliary variables if any.
|
||
(dcls nil) ;declarations associated with the frag.
|
||
(alterable nil) ;specifications for alterable outputs
|
||
(prolog nil) ;list of forms (without labels).
|
||
(body nil) ;list of forms (possibly containing labels).
|
||
(epilog nil) ;list of forms (without labels).
|
||
(wrappers nil)) ;functions that wrap forms around the whole loop.
|
||
|
||
;;;; Hack to get around Lyric XCL bug where default FRAG-P of NIL gives error
|
||
#+Xerox(xcl:definline frag-p (object) (and (consp object) (frag-p-internal object)))
|
||
|
||
;there cannot be any redundancy in or between the args and aux. Each ret
|
||
;variable must be either on the args list or the aux list. The args
|
||
;and ret have additional data as discussed below. The aux is just a list
|
||
;of symbols. Every symbol used in a frag which could possible clash
|
||
;with other frags (eg args, rets, aux, and also labels) must be
|
||
;gensyms and unique in the whole world.
|
||
|
||
;the order of the args is important when the frag is first
|
||
;instantiated and funcallSed. However, it does not matter after that.
|
||
;Similarly, the order of the rets also matters at the time it is
|
||
;instantiated, and at the time that a whole expression is turned into
|
||
;one frag, but it does not matter at other times.
|
||
|
||
;there are two basic kinds of frags, oss frags and non-oss frags. A non-oss
|
||
;frag is a frag which just has a simple computation which has to be performed
|
||
;only once. The rets and args must be non-oss values, and the body and epilog
|
||
;must be empty. (The code below maintains the invariant that if all
|
||
;the ports of a frag are non-oss then the body and epilog are empty.)
|
||
|
||
;a frag has three internal parts so that a wide variety of fragmentary
|
||
;oss functions can be compressed into a single frag. (This is what
|
||
;lambdaS does.) (Actually, any kind of fragmentary oss function can
|
||
;be represented. However, to compress a thing like (Elist (Rlist S))
|
||
;(and other weird things) into a single frag, the input would have to
|
||
;be made off-line. This is not done automatically, because it is
|
||
;against the spirit of oss.)
|
||
|
||
;Inside frags there is a label which has a special meaning.
|
||
; END is used as the label after the end of the loop created. If the
|
||
; body of a fragment contains (go END) then the fragment is an
|
||
; active terminator.
|
||
;If a programmer uses this symbols in his program, very bad
|
||
;things could happen. However, it is in the oss package, so
|
||
;there should not be any conflict problems.
|
||
|
||
;the code in this file assumes in many places that no oss: symbol can
|
||
;possibly clash with a user symbol.
|
||
|
||
(defun annotate (code frag)
|
||
(setf (code frag) code)
|
||
frag)
|
||
|
||
;Considerable effort is expended to see that the code field always
|
||
;contains code that makes sense to the user. Extensive testing
|
||
;indicates that it never ends up containing :?, and that the code it
|
||
;contains always is part of the code the user types except that an
|
||
;optional argument can end up having the default value which ends up
|
||
;in the annotation.
|
||
|
||
;Each arg and ret has the following parts.
|
||
|
||
(defstruct (sym (:conc-name nil) (:type list) #+Xerox(:predicate sym-p-internal) :named)
|
||
(back-ptrs (make-array 2 :initial-element nil))
|
||
(var nil) ;gensymed variable.
|
||
(oss-var-p nil) ;T if holds a series.
|
||
(off-line-spot nil) ;if off-line, place to insert the computation.
|
||
(off-line-exit nil)) ;if non-passive input, label to catch exit.
|
||
|
||
;;;; Hack to get around Lyric XCL bug where default SYM-P of NIL gives error
|
||
#+Xerox(xcl:definline sym-p (object) (and (consp object) (sym-p-internal object)))
|
||
|
||
;if there is an on-line-spot, it must appear in the frag code exactly
|
||
;once at top level. It cannot be nested in a form. Several args can
|
||
;have the same off-line-spot symbol. This indicates that they are all
|
||
;in phase with each other.
|
||
|
||
;a number of functions depend on the fact that frags and syms are list
|
||
;structures which can be traversed by functions like nsubst. The
|
||
;following three circular pointers are hidden in an array so they
|
||
;won't be followed. (Note that ins only have prv and rets only have
|
||
;nxts, as a result, they can both be stored in the same place. two
|
||
;names are used in order to enhance the readability of the program.)
|
||
|
||
(eval-when (eval load compile)
|
||
(defmacro fr (s) ;back pointer to containing frag.
|
||
`(aref (back-ptrs ,s) 0))
|
||
(defmacro nxts (s) ;list of destinations of dflows starting here.
|
||
`(aref (back-ptrs ,s) 1))
|
||
(defmacro prv (s) ;the single source of dflow to here.
|
||
`(aref (back-ptrs ,s) 1)) )
|
||
|
||
;The sym vars are symbols which appear in the body of the frag where they
|
||
;should. All of the symbols must be unique in all the world. Every instance
|
||
;of the symbol anywhere must be a use of the symbol.
|
||
; Output variables can be freely read and written.
|
||
;Input variables can be read freely, but cannot ever be written.
|
||
; These restrictions guarantee that when frags are combined, it is OK to
|
||
;rename the input var of one to be the output var of the other. In
|
||
;addition, the creator of an output can depend on the output variable
|
||
;being unchanged by the user(s). However, this is not the main point.
|
||
;More critical is the situation where two frags use the same value.
|
||
;The second frag can be sure that the first frag did not wreck the value.
|
||
;(Side-effects could still cause problems. The user must guard
|
||
;against destroying some other fragment's internal state.)
|
||
; In the interest of good output code, some work is done to simplify
|
||
;things when frags are merged. If an output is of the form (setq out c)
|
||
;where c is T, nil, or a number, then c is substituted directly for the
|
||
;input. Substitution is also applied if c is a variable which is not
|
||
;bound in the destination frag. In addition, other kinds of constants
|
||
;are substituted if they are only used in one place. A final pass
|
||
;gets rid of setqs to variables that are never used for anything.
|
||
|
||
#+:GCLISP
|
||
(eval-when (eval load compile)
|
||
(defsetf fr set-fr)
|
||
(defmacro set-fr (s value)
|
||
`(setf (aref (back-ptrs ,s) 0) ,value))
|
||
(defsetf nxts set-nxts)
|
||
(defmacro set-nxts (x value)
|
||
`(setf (aref (back-ptrs ,s) 1) ,value))
|
||
(defsetf prv set-nxts) )
|
||
|
||
;The third key internal form is a graph of frags. This is
|
||
;represented in an indirect way. The special variable *graph*
|
||
;contains a list of all of the frags in the oss expression currently
|
||
;being processed. The order of the frags in this list is vitally
|
||
;important. It corresponds to their lexical order in the input
|
||
;expression and controls the default way things with no data flow
|
||
;between them are ordered when combined. In addition, many of the
|
||
;algorithms depend on the fact that the order in *graph* is compatible
|
||
;with the data flow in that there can never be data flow from a frag
|
||
;to an earlier frag in the list.
|
||
|
||
;Subexpressions and regions within the expression as a whole are
|
||
;delineated by setting marking bits in the frags in the region.
|
||
|
||
;LambdaS makes special frags for arguments which are not in the list
|
||
;*graph*. They exist to record info about the arguments and to
|
||
;preserve an invariant that every input of every frag in *graph* must
|
||
;have data flow ending on it. A related invariant states that if a
|
||
;frag in *graph* has a ret then this ret must be used either by having
|
||
;dflow from it, or as an output of the expression as a whole. Unused
|
||
;rets are removed from frags when the frags are created.
|
||
|
||
;for the purposes of testing whether a subexpression is strongly
|
||
;connected to its outputs, a frag with no rets is considered to be an
|
||
;output of the subexpression.
|
||
|
||
;This has to be called to set things up right, before processing of a
|
||
;OSS expression can proceed.
|
||
|
||
(defvar *oss-tutorial-mode* nil "controls tutorial mode")
|
||
(defvar *in-oss-expr* nil "the topmost OSS expression")
|
||
|
||
(proclaim '(special *graph* ;list of frags in expression
|
||
*renames* ;alist of variable renamings
|
||
*user-names* ;lets var names used by user
|
||
*env*)) ;environment of containing series macro call
|
||
|
||
;*renames* has three kinds of entries on it. Each is a cons of a
|
||
;variable and something else: (type 1 cannot ever be setqed.)
|
||
; 1- a ret, var is a lets var or a lambdaS var.
|
||
; you can tell between the two because lambdaS var frags are not in *graph*.
|
||
; 2- a new var, var is an aux var.
|
||
; 3- nil, var is rebound and protected from renaming.
|
||
|
||
;should have some general error catching thing but common lisp has none.
|
||
|
||
(eval-when (eval load compile)
|
||
(defmacro top-starting-oss-expr (call &body body)
|
||
`(catch :oss-error
|
||
(starting-oss-expr ,call . ,body)))
|
||
|
||
(defmacro starting-oss-expr (call &body body)
|
||
`(let ((*renames* nil)
|
||
(*user-names* nil)
|
||
(*in-oss-expr* (iterative-copy-tree ,call))) ;avoids side-effects
|
||
(setq *last-oss-loop* nil)
|
||
. ,body))
|
||
|
||
;This does two key things. First, it checks to see whether an oss
|
||
;expression is starting. As a result, defmacroS must be used to define
|
||
;every macro which can possibly start an OSS expression. Second, if
|
||
;and only if the body returns a frag which does not already have its
|
||
;code field filled in, the macro call is put in the code field of the
|
||
;frag. This provides a very useful default for the annotation.
|
||
;(Never let anything expand into a defmacroSed form, or the user can
|
||
;end up seeing something in an error message that he never wrote.)
|
||
|
||
(defmacro defmacroS (name arglist &body body)
|
||
`(defmacro ,name (&whole +call+ . ,arglist)
|
||
,@(if (stringp (car body)) (list (pop body)))
|
||
,@(if (eq (caar body) 'declare) (list (pop body)))
|
||
(if (not *in-oss-expr*)
|
||
(let ((result (macroexpand-1 (list 'process-top +call+))))
|
||
(if (not (consp result)) (setq result (list 'progn result)))
|
||
(rplaca +call+ (car result)) ;avoids reexpansions
|
||
(rplacd +call+ (cdr result))
|
||
result)
|
||
(let* ((+call+ (iterative-copy-tree +call+)) ;avoids side-effects
|
||
(result (progn . ,body)))
|
||
(when (and (frag-p result) (eq (code result) :?))
|
||
(setf (code result) +call+))
|
||
result))))
|
||
|
||
(defmacro process-top ;this snarfs the env ptr.
|
||
(call #-:GCLISP &environment #-:GCLISP *env*)
|
||
;; COPY-TREE so we don't smash user's code
|
||
(top-starting-oss-expr (copy-tree call) (codify (mergify (graphify call))))) )
|
||
|
||
(defun ers (id msg &rest args)
|
||
(setq *last-oss-error* (list* id msg (copy-list args)))
|
||
(warn "Error ~A in OSS expression:~%~S~%~?" id *in-oss-expr* msg args)
|
||
(throw :oss-error id))
|
||
|
||
(defun wrs (id msg &rest args)
|
||
(setq *last-oss-error* (list* id msg (copy-list args)))
|
||
(warn "~A in OSS expression:~%~S~%~?" id *in-oss-expr* msg args))
|
||
|
||
;--------------------------------------------------
|
||
|
||
(defun non-oss-p (frag)
|
||
(and (notany #'(lambda (x) (oss-var-p x)) (rets frag))
|
||
(notany #'(lambda (x) (oss-var-p x)) (args frag))))
|
||
|
||
(defun active-terminator-p (frag)
|
||
(or (branches-to 'END (prolog frag))
|
||
(branches-to 'END (body frag))))
|
||
|
||
(defun off-line-p (frag)
|
||
(or (some #'(lambda (a) (off-line-spot a)) (args frag))
|
||
(some #'(lambda (r) (off-line-spot r)) (rets frag))))
|
||
|
||
(defun on-line-p (frag)
|
||
(not (off-line-p frag)))
|
||
|
||
;this assumes that every instance of one of OSSs funny labels is
|
||
;really an instance of that label made by the macros below.
|
||
|
||
(defun branches-to (label tree)
|
||
(cond ((and (eq-car tree 'tagbody) (member label tree)) nil)
|
||
((and (eq-car tree 'go) (eq-car (cdr tree) label)) T)
|
||
(T (do ((tt tree (cdr tt)))
|
||
((not (consp tt)) nil)
|
||
(if (branches-to label (car tt)) (return T))))))
|
||
|
||
;hacking marks
|
||
|
||
(defun reset-marks (&optional (value 0))
|
||
(dolist (f *graph*)
|
||
(setf (marks f) value)))
|
||
|
||
(defun mark (mask frag) ;sets bits on
|
||
(setf (marks frag) (logior mask (marks frag))))
|
||
|
||
(defun marked-p (mask frag) ;checks that all bits are on
|
||
(zerop (logandc2 mask (marks frag))))
|
||
|
||
(eval-when (eval load compile)
|
||
(defmacro dofrags ((var . mask) &body body) ;mask should be a constant
|
||
(when mask
|
||
(setq body `((when (marked-p ,(car mask) ,var) . ,body))))
|
||
`(dolist (,var *graph*) . ,body)) )
|
||
|
||
;many of the functions in this file depend on the fact that frags and
|
||
;syms are list structures. However, only the following functions (and defS)
|
||
;depend on the exact position of parts of these structures. Note that
|
||
;the CL manual guarantees that these positions are correct in all
|
||
;implementations.
|
||
|
||
(defun merge-frags (frag1 frag2)
|
||
(mapc #'(lambda (s) (setf (fr s) frag2)) (rets frag1))
|
||
(mapc #'(lambda (s) (setf (fr s) frag2)) (args frag1))
|
||
(mapl #'(lambda (f1 f2) (rplaca f2 (nconc (car f1) (car f2))))
|
||
(cdddr frag1) (cdddr frag2))
|
||
frag2)
|
||
|
||
(defun copy-fragment (frag)
|
||
(let* ((alist (mapcar #'(lambda (v) (cons v (gensym (root v))))
|
||
(find-gensyms frag)))
|
||
(new-frag (list* 'frag (code frag)
|
||
(nsublis alist (iterative-copy-tree (cddr frag))))))
|
||
(dolist (a (args new-frag))
|
||
(copy-ptrs a new-frag))
|
||
(dolist (r (rets new-frag))
|
||
(copy-ptrs r new-frag))
|
||
new-frag))
|
||
|
||
(defun copy-ptrs (sym frag)
|
||
(setf (back-ptrs sym) (make-array 2))
|
||
(setf (nxts sym) nil)
|
||
(setf (fr sym) frag))
|
||
|
||
(defun frag->list (frag)
|
||
(setf (rets frag) (mapcar #'cddr (rets frag)))
|
||
(setf (args frag) (mapcar #'cddr (args frag)))
|
||
(let ((gensyms (find-gensyms frag)))
|
||
(nsublis (mapcar #'(lambda (v) (cons v (gentemp (root v)))) gensyms)
|
||
(cons gensyms (cdddr frag)))))
|
||
|
||
(defun find-gensyms (tree &optional (found nil))
|
||
(do ((tt tree (cdr tt)))
|
||
((not (consp tt))
|
||
(if (and (symbolp tt) (null (symbol-package tt)))
|
||
(adjoin tt found)
|
||
found))
|
||
(setq found (find-gensyms (car tt) found))))
|
||
|
||
(defun root (symbol)
|
||
(let* ((string (string symbol))
|
||
(pos (position #\- string :start (min (length string) 1))))
|
||
(if pos (subseq string 0 (1+ pos)) (concatenate 'string string "-"))))
|
||
|
||
(defun list->frag (list)
|
||
(let* ((alist (mapcar #'(lambda (v) (cons v (gensym (root v)))) (pop list)))
|
||
(frag (list* 'frag :? 0 (nsublis alist (iterative-copy-tree list)))))
|
||
(setf (args frag) (mapcar #'(lambda (s) (list->sym s frag)) (args frag)))
|
||
(setf (rets frag) (mapcar #'(lambda (s) (list->sym s frag)) (rets frag)))
|
||
(values frag alist)))
|
||
|
||
(defun list->sym (list frag)
|
||
(let ((s (make-sym :var (car list) :oss-var-p (cadr list)
|
||
:off-line-spot (caddr list)
|
||
:off-line-exit (cadddr list))))
|
||
(setf (fr s) frag)
|
||
s))
|
||
|
||
;some Common Lisps implement copy-tree tail recursively.
|
||
|
||
(defun iterative-copy-tree (tree)
|
||
(do ((tail tree (cdr tail))
|
||
(r nil (cons (iterative-copy-tree (car tail)) r)))
|
||
((not (consp tail)) (nreconc r tail))))
|
||
|
||
(defun literal-frag (stuff) ;(args rets aux dcls alt prolog body epilog wraprs)
|
||
(let ((gensyms (nconc (mapcar #'car (nth 0 stuff)) (nth 2 stuff))))
|
||
(dolist (f (nth 6 stuff))
|
||
(if (symbolp f) (push f gensyms)))
|
||
(list->frag (cons gensyms stuff))))
|
||
|
||
(eval-when (eval load compile)
|
||
(defmacro delete1 (thing list)
|
||
`(setf ,list (delete1a ,thing ,list))) )
|
||
|
||
(defun delete1a (item list)
|
||
(if (eq item (car list)) (cdr list)
|
||
(do ((l list (cdr l)))
|
||
((null (cdr list)))
|
||
(when (eq item (cadr l))
|
||
(rplacd l (cddr l))
|
||
(return list)))))
|
||
|
||
(defun +arg (arg frag)
|
||
(setf (fr arg) frag)
|
||
(setf (args frag) (nconc (args frag) (list arg)))) ;needed by Tcotruncate
|
||
|
||
(defun -arg (arg)
|
||
(delete1 arg (args (fr arg))))
|
||
|
||
(defun +ret (ret frag)
|
||
(setf (fr ret) frag)
|
||
(setf (rets frag) (nconc (rets frag) (list ret)))) ;needed by force-n-rets
|
||
|
||
(defun -ret (ret)
|
||
(delete1 ret (rets (fr ret))))
|
||
|
||
(defun +frag (frag)
|
||
(setf *graph* (nconc *graph* (list frag))) ;needed to keep order right
|
||
frag)
|
||
|
||
(defun -frag (frag)
|
||
(delete1 frag *graph*)
|
||
(setf (marks frag) 0)) ;important so dofrags will notice deletions
|
||
|
||
(defun +dflow (source dest)
|
||
(push dest (nxts source))
|
||
(setf (prv dest) source))
|
||
|
||
(defun -dflow (source dest)
|
||
(delete1 dest (nxts source))
|
||
(setf (prv dest) nil))
|
||
|
||
(defun all-nxts (frag)
|
||
(apply #'append (mapcar #'(lambda (r) (nxts r)) (rets frag))))
|
||
|
||
(defun all-prvs (frag)
|
||
(delete nil (mapcar #'(lambda (a) (prv a)) (args frag))))
|
||
|
||
; TURNING AN EXPRESSION INTO A GRAPH
|
||
|
||
; This parses code down to fundamental chunks creating a graph of the
|
||
;expression. Note that macroexpanding and renaming is applied while
|
||
;this happens.
|
||
|
||
(defun graphify (code)
|
||
(let ((*graph* nil))
|
||
(fragify code)
|
||
*graph*))
|
||
|
||
;note have to be careful in the next two functions not to expand things twice.
|
||
;If you did, you could get two copies of some frags on *graph*.
|
||
|
||
(defun retify (code &aux expansion ret)
|
||
(setq expansion (my-macroexpand code))
|
||
(cond ((sym-p expansion) expansion)
|
||
((sym-p (setq ret (cdr (assoc expansion *renames*)))) ret)
|
||
(T (if (not (frag-p expansion))
|
||
(setq expansion (isolate-non-oss code expansion)))
|
||
(car (rets (force-n-rets 1 expansion))))))
|
||
|
||
(defun fragify (code &aux expansion)
|
||
(setq expansion (my-macroexpand code))
|
||
(if (not (frag-p expansion))
|
||
(setq expansion (isolate-non-oss code expansion)))
|
||
expansion)
|
||
|
||
(defun force-n-rets (n frag)
|
||
(let ((len (length (rets frag))))
|
||
(cond ((= n len))
|
||
((> n len)
|
||
(ers 8 "Only ~A return values present where ~A expected~%~A"
|
||
len n (code frag)))
|
||
(T (mapc #'kill-ret (nthcdr n (rets frag))))))
|
||
frag)
|
||
|
||
(defun kill-ret (ret)
|
||
(when (off-line-spot ret)
|
||
(setf (body (fr ret))
|
||
(nsubst-inline nil (off-line-spot ret) (body (fr ret)))))
|
||
(-ret ret))
|
||
|
||
;This makes a non-oss frag to start with, mapping (if needed) happens later.
|
||
;Rationale: we always group the biggest chunk possible into one thing
|
||
;because if it doesn't get mapped it doesn't matter and if it does
|
||
;get mapped and you don't want it all to be mapped, you can easily
|
||
;fix the problem by inserting (Eoss :R ...). If we took a small piece when
|
||
;you wanted a large one, there would be no easy way for you to fix things.
|
||
;This also sets annotation on the frag produced. For this to work
|
||
;right, it is important that isolate-non-oss is never called on
|
||
;anything but user code.
|
||
|
||
(defun isolate-non-oss (annotation code)
|
||
(let* ((var (gensym "OUT-"))
|
||
(frag (make-frag :code annotation :aux (list var)))
|
||
(top-renames *renames*)
|
||
(exp (m-&-r code
|
||
#'(lambda (c)
|
||
(if (not (or (frag-p c) (sym-p c))) c
|
||
(let ((arg (make-sym :var (gensym "ARG-"))))
|
||
(+arg arg frag)
|
||
(if (frag-p c) (check-movability code c top-renames))
|
||
(+dflow (retify c) arg)
|
||
(var arg)))))))
|
||
(+ret (make-sym :var var) frag)
|
||
(setf (prolog frag) `((setq ,var ,exp)))
|
||
(+frag frag)))
|
||
|
||
;this should really check if any bound vars are referenced, and should
|
||
;look to see if any special variables are being bound. (We have to
|
||
;look at the code field, because the subexpr may have been turned into
|
||
;several frags).
|
||
|
||
(defun check-movability (top-code frag top-renames)
|
||
(if (contains-p (mapcar #'car (ldiff *renames* top-renames)) (code frag))
|
||
(wrs 13 "Decomposition moves:~%~S~%out of a binding scope:~%~S"
|
||
(code frag) top-code)))
|
||
|
||
(defun contains-p (items thing)
|
||
(do ((tt thing (cdr tt)))
|
||
((not (consp tt)) (member tt items))
|
||
(if (contains-p items (car tt)) (return T))))
|
||
|
||
(defmacroS mapS (&body expr-list)
|
||
"Causes EXPR-LIST to be mapped over the OSS variables in it."
|
||
(setq expr-list (process-subforms expr-list))
|
||
(isolate-non-oss +call+
|
||
(if (null (cdr expr-list)) (car expr-list) `(progn . ,expr-list))))
|
||
|
||
;This expands all of the OSS exprs in forms as if they were in
|
||
;isolation. You can process the result again, if you want it to be
|
||
;able to refer to OSS vars from outside.
|
||
(defun process-subforms (forms)
|
||
(let ((*in-oss-expr* nil) (*renames* nil) (*user-names* nil))
|
||
(mapcar #'m-&-r forms)))
|
||
|
||
(defmacroS funcallS (function &rest expr-list)
|
||
"Applies an OSS function to the results of the expressions."
|
||
(annotate +call+
|
||
(if (frag-p function) (funcallS-frag0 function expr-list +call+)
|
||
(case (quoted-function-p (setq function (my-macroexpand function)))
|
||
(lambdaS
|
||
(funcallS-frag0 (process-lambdas function (cadr function))
|
||
expr-list +call+))
|
||
(lambda-primitiveS
|
||
(funcallS-frag0 (process-lambda-primitiveS function (cadr function))
|
||
expr-list +call+))
|
||
(symbol
|
||
(let ((code (my-macroexpand (cons (cadr function) expr-list))))
|
||
(if (frag-p code) code (do-TmapF function expr-list))))
|
||
(otherwise (do-TmapF function expr-list))))))
|
||
|
||
(defun quoted-function-p (thing)
|
||
(cond ((not (eq-car thing 'function)) nil)
|
||
((symbolp (cadr thing)) 'symbol)
|
||
((eq-car (cadr thing) 'lambda) 'lambda)
|
||
((eq-car (cadr thing) 'lambdaS) 'lambdaS)
|
||
((eq-car (cadr thing) 'lambda-primitiveS) 'lambda-primitiveS)))
|
||
|
||
(defun funcallS-frag0 (frag values call)
|
||
(when (not (= (length values) (length (args frag))))
|
||
(ers 7 "Wrong number of args to funcallS:~%~S" call))
|
||
(funcallS-frag frag values))
|
||
|
||
(defun funcallS-frag (frag values)
|
||
(mapc #'(lambda (v a) (+dflow (retify v) a)) values (args frag))
|
||
(+frag frag))
|
||
|
||
(defmacroS prognS (&rest expr-list)
|
||
"Delineates an OSS expression."
|
||
(process-progns expr-list))
|
||
|
||
(defun process-progns (forms)
|
||
(mapc #'(lambda (f) (force-n-rets 0 (fragify f))) (butlast forms))
|
||
(fragify (car (last forms)))) ;forces NIL if no forms.
|
||
|
||
;note that this forces the values to either be all non-oss or all oss
|
||
;and on-line with each other. If you want more complicated outputs, you
|
||
;have to use the primitive definition facilities.
|
||
|
||
(defmacroS valS (&rest expr-list)
|
||
"Returns multiple series values."
|
||
(let ((frag (make-frag)))
|
||
(dotimes (i (length expr-list) i)
|
||
(let ((var (gensym "VAL-")))
|
||
(+arg (make-sym :var var) frag)
|
||
(+ret (make-sym :var var) frag)))
|
||
(funcalls-frag frag expr-list)))
|
||
|
||
;LetS assumes that pass-valS doesn't appear in annotation.
|
||
(defmacroS pass-valS (n expr)
|
||
"Used to pass multiple values from a non-OSS function into an OSS expression."
|
||
(setq expr (my-macroexpand expr))
|
||
(cond ((frag-p expr) (force-n-rets n expr))
|
||
((= n 1) (annotate expr (fragify expr)))
|
||
(T (let ((vars nil) frag) ;note expr must be non-oss at top.
|
||
(dotimes (x n)
|
||
(push (gensym "VAL-") vars))
|
||
(setq frag (fragify `(multiple-value-setq ,vars ,expr)))
|
||
(setf (rets frag) nil)
|
||
(dolist (v vars)
|
||
(push v (aux frag))
|
||
(+ret (make-sym :var v) frag))
|
||
(annotate expr frag)))))
|
||
|
||
(defmacroS letS* (var-value-pair-list &body expr-list)
|
||
"Binds OSS variables in parallel."
|
||
(let ((*renames* *renames*) (old-top *renames*))
|
||
(dolist (p var-value-pair-list)
|
||
(setq *renames* (process-lets-pair p *renames*)))
|
||
(process-lets-body expr-list (ldiff *renames* old-top) +call+)))
|
||
|
||
(defmacroS letS (var-value-pair-list &body expr-list)
|
||
"Binds OSS variables sequentially."
|
||
(let ((new-renames *renames*) (old-top *renames*))
|
||
(dolist (p var-value-pair-list)
|
||
(setq new-renames (process-lets-pair p new-renames)))
|
||
(let ((*renames* new-renames))
|
||
(process-lets-body expr-list (ldiff *renames* old-top) +call+))))
|
||
|
||
(defun process-lets-pair (p alist)
|
||
(setq p (normalize-pair p))
|
||
(let* ((vars (car p))
|
||
(frag (fragify `(pass-valS ,(length vars) ,(cadr p)))))
|
||
(mapc #'(lambda (v r)
|
||
(cond (v (push (cons v r) alist)
|
||
(push (cons (var r) v) *user-names*))
|
||
(T (kill-ret r))))
|
||
vars (copy-list (rets frag)))
|
||
alist))
|
||
|
||
(defun normalize-pair (p)
|
||
(cond ((and (consp p) (bind-var-p (car p)) (= (length p) 2))
|
||
(list (list (car p)) (cadr p)))
|
||
((and (consp p) (consp (car p)) (every #'bind-var-p (car p))
|
||
(= (length p) 2)) p)
|
||
(T (ers 9 "Malformed letS{*} binding pair ~S." p))))
|
||
|
||
(defun bind-var-p (thing)
|
||
(or (null thing) (lambda-variable-p thing)))
|
||
|
||
(defun lambda-variable-p (thing)
|
||
(and (variable-p thing)))
|
||
|
||
(defun variable-p (thing)
|
||
(and thing (symbolp thing) (not (eq thing T)) (not (keywordp thing))
|
||
(not (member thing lambda-list-keywords))))
|
||
|
||
(defun process-lets-body (forms alist call)
|
||
(setq forms (normalize-dcls forms))
|
||
(when (cddadr (car forms))
|
||
(wrs 10 "The variable(s) ~S declared TYPE OSS in a letS{*}."
|
||
(cddadr (car forms))))
|
||
(pop forms)
|
||
(let ((dcls (process-subforms-&-rename (cdr (pop forms))))
|
||
(frag (process-progns forms)))
|
||
(setf (dcls frag) (append dcls (dcls frag))) ;assumes outputs never renamed
|
||
(dolist (entry alist)
|
||
(when (null (nxts (cdr entry)))
|
||
(wrs 11 "The letS variable ~A is unused in:~%~A" (car entry) call)))
|
||
frag))
|
||
|
||
(defun process-subforms-&-rename (forms)
|
||
(mapcar #'rename (process-subforms forms)))
|
||
|
||
(defun rename (form)
|
||
(m-&-r form #'(lambda (c) (if (sym-p c) (var c) c))))
|
||
|
||
(defmacroS lambdaS (var-list &body expr-list)
|
||
"Form for specifying literal OSS functions."
|
||
(declare (ignore var-list expr-list))
|
||
(ers 6 "LambdaS used in inappropriate context:~%~S" +call+))
|
||
|
||
(defun process-lambdas (call lambdas)
|
||
(starting-oss-expr call
|
||
(let* ((arglist (cadr lambdas))
|
||
(forms (normalize-dcls (cddr lambdas)))
|
||
(oss-vars (cddadr (pop forms)))
|
||
(dcl (pop forms))
|
||
(arg-frag-rets
|
||
(mapcar
|
||
#'(lambda (a)
|
||
(when (not (lambda-variable-p a))
|
||
(ers 5 "Malformed lambdaS argument ~S." a))
|
||
(let* ((ret (make-sym
|
||
:var (gensym "ARG-")
|
||
:oss-var-p (not (null (member a oss-vars)))))
|
||
(arg-frag (make-frag)))
|
||
(+ret ret arg-frag)
|
||
(push (cons a ret) *renames*)
|
||
ret))
|
||
arglist))
|
||
(frag (mergify (graphify `(prognS . ,forms)))))
|
||
(setf (args frag) ;get into the right order.
|
||
(mapcar #'handle-arg arg-frag-rets))
|
||
(setf (dcls frag) (append (process-subforms-&-rename (cdr dcl))
|
||
(dcls frag)))
|
||
frag)))
|
||
|
||
(defun handle-arg (ret)
|
||
(let ((arg (car (nxts ret))))
|
||
(when (null arg) (setq arg ret)) ;input never used
|
||
(setf (prv arg) nil)
|
||
(dolist (a (cdr (nxts ret))) ;input used more than once.
|
||
(nsubst (var arg) (var a) (fr a)))
|
||
arg))
|
||
|
||
(defun normalize-dcls (forms &optional (allow-doc nil))
|
||
(let ((doc nil) (oss-vars nil) (others nil))
|
||
(prog ()
|
||
L (when (and allow-doc (null doc) (stringp (car forms)) (cdr forms))
|
||
(setq doc (pop forms)) (go L))
|
||
(when (not (eq-car (car forms) 'declare)) (return nil))
|
||
(dolist (d (cdr (pop forms)))
|
||
(if (and (eq-car d 'type) (listp (cdr d)) (symbolp (cadr d))
|
||
(string-equal (string (cadr d)) "OSS"))
|
||
(setq oss-vars (append (cddr d) oss-vars))
|
||
(push d others)))
|
||
(go L))
|
||
`(,@(if doc (list doc))
|
||
(declare (type oss . ,oss-vars))
|
||
(declare . ,others)
|
||
. ,forms)))
|
||
|
||
(defmacro defunS (name lambda-list
|
||
#-:GCLISP &environment #-:GCLISP *env*
|
||
&body expr-list)
|
||
"Defines an OSS function, see LAMBDAS."
|
||
(let ((call (list* 'defunS name lambda-list expr-list)))
|
||
(top-starting-oss-expr call
|
||
(dolist (v lambda-list)
|
||
(when (and (member v lambda-list-keywords)
|
||
(not (member v '(&optional &key))))
|
||
(ers 3 "Unsuported &-keyword ~S in defunS arglist." v)))
|
||
(let ((vars nil) (rev-arglist nil))
|
||
(dolist (a lambda-list)
|
||
(cond ((member a lambda-list-keywords) (push a rev-arglist))
|
||
(T (setq a (iterative-copy-tree a))
|
||
(setq vars (append vars (vars-of a)))
|
||
(if (and (listp a) (listp (cdr a)))
|
||
(setf (cadr a) `(copy-tree ',(cadr a))))
|
||
(push a rev-arglist))))
|
||
(setq expr-list (normalize-dcls expr-list T))
|
||
`(defmacroS ,name ,(reverse rev-arglist)
|
||
,@(if (stringp (car expr-list)) (list (pop expr-list)))
|
||
(funcallS-frag
|
||
(list->frag
|
||
',(frag->list
|
||
(process-lambdas call `(lambdaS ,vars . ,expr-list))))
|
||
(list . ,vars)))))))
|
||
|
||
(defun vars-of (arg)
|
||
(cond ((member arg lambda-list-keywords) nil)
|
||
((not (consp arg)) (list arg))
|
||
(T (cons (if (consp (car arg)) (cadr arg) (car arg))
|
||
(copy-list (cddr arg))))))
|
||
|
||
;note the following does not assume that old and new are series
|
||
;(implicit mapping will happen if they are). Also the alterS form found
|
||
;probably refers to vars which are not OLD itself. This is ok because outputs
|
||
;never get renamed. Also the input old to the frag most likely never
|
||
;gets used, but this makes sure that the dflow is logically correct.
|
||
|
||
;It is vital that this doesn't put the setf in the frag, because it is
|
||
;important that the setf get combined with any IF or other form it is
|
||
;nested in when implicit mapping happens.
|
||
|
||
;This makes the right annotation, because it does not expand into a
|
||
;frag. As a result, instantiate-non-oss always ends up getting called
|
||
;around it and makes the right annotation.
|
||
|
||
(defmacroS alterS (destinations items) ;fix so can be top level
|
||
"Alters the values in DESTINATIONS to be ITEMS."
|
||
(let ((ret (retify destinations)))
|
||
(let ((form (find-alter-form ret)))
|
||
(when (null form)
|
||
(ers 4 "AlterS applied to an unalterable form:~%~S" +call+))
|
||
`(setf ,form
|
||
,(annotate +call+
|
||
(funcallS-frag
|
||
(literal-frag ;this gets the data flow dependencies right.
|
||
`(((old) (items)) ((items)) () () () () () () ()))
|
||
(list ret items)))))))
|
||
|
||
(defun find-alter-form (ret)
|
||
(let* ((v (var ret))
|
||
(form (cadr (assoc v (alterable (fr ret))))))
|
||
(if form form
|
||
(dolist (a (args (fr ret)))
|
||
(when (or (eq v (var a))
|
||
(equal (prolog (fr ret)) `((setq ,v ,(var a)))))
|
||
(return (find-alter-form (prv a))))))))
|
||
|
||
; MERGING A GRAPH
|
||
|
||
;this proceeds in three phases
|
||
; (1) Implicit mapping and the like to fix type conflicts.
|
||
; (a) find all non-series functions which must be mapped.
|
||
; (b) signal error if there is a non-fixable oss/non-oss type conflict.
|
||
; (c) Insert (Eoss :R ...) where needed to fix non-oss/oss type conflicts.
|
||
; (2) doing substitutions to get rid of trivial frags and improve the code.
|
||
; (3) the graph is scanned to find a dflow which should be isolated.
|
||
; when one is found, the graph is split at this point. The two
|
||
; subgraphs are merged separately and then combined. If the graph
|
||
; cannot be split, then it consists solely of on-line dflow and can be
|
||
; easily merged.
|
||
|
||
(defun mergify (*graph*)
|
||
(reset-marks)
|
||
(do-coercion)
|
||
(do-substitution)
|
||
(eval (do-splitting *graph*)))
|
||
|
||
;takes advantage of the fact that frags are ordered consistently
|
||
;with the dflow so an implicit mapping of one fn cannot force earlier
|
||
;functions to be mapped.
|
||
|
||
(defun do-coercion ()
|
||
(dofrags (f)
|
||
(when (and (non-oss-p f)
|
||
(some #'(lambda (r) (oss-var-p r)) (all-prvs f)))
|
||
(implicit-map f))
|
||
(dolist (a (args f)) ;if map might have to map only some args.
|
||
(let ((ret (prv a)))
|
||
(cond ((and (not (oss-var-p ret)) (oss-var-p a))
|
||
(Eoss-coerce a))
|
||
((and (oss-var-p ret) (not (oss-var-p a)))
|
||
(ers 14 "OSS value carried to non-OSS input ~
|
||
by data flow from:~%~S~%to:~%~S"
|
||
(code (fr ret)) (code f))))))
|
||
(maybe-de-oss f))) ;might have to if Eoss coerced all of the inputs
|
||
|
||
(defun implicit-map (frag)
|
||
(setf (body frag) (prolog frag))
|
||
(setf (prolog frag) nil)
|
||
(dolist (a (args frag)) (setf (oss-var-p a) T))
|
||
(dolist (r (rets frag)) (setf (oss-var-p r) T))
|
||
frag)
|
||
|
||
(defun Eoss-coerce (a)
|
||
(when (off-line-spot a)
|
||
(nsubst nil (off-line-spot a) (fr a)))
|
||
(setf (oss-var-p a) nil))
|
||
|
||
;choose not to automatically map subexprs because it helps detect bugs,
|
||
;and doesn't take away much you want to do.
|
||
|
||
(defun do-substitution ()
|
||
(dofrags (f)
|
||
(multiple-value-bind (subable code) (substitutable-source f)
|
||
(when subable
|
||
(let* ((ret (car (rets f)))
|
||
(killable (not (null (nxts ret)))))
|
||
(dolist (arg (nxts ret))
|
||
(cond ((substitutable-destination ret arg code)
|
||
(nsubst code (var arg) (fr arg))
|
||
(-dflow ret arg)
|
||
(-arg arg))
|
||
(T (setq killable nil))))
|
||
(if killable (-frag f)))))))
|
||
|
||
(defun substitutable-source (f &aux code fn-type)
|
||
(values (and (= (length (rets f)) 1)
|
||
(not (off-line-spot (car (rets f))))
|
||
(null (args f))
|
||
(null (epilog f))
|
||
(= 1 (length (setq code (append (prolog f) (body f)))))
|
||
(eq (var (car (rets f))) (setq-p (setq code (car code))))
|
||
;;cheap check for free vars not bound in destination
|
||
(or (constantp (setq code (caddr code))) (symbolp code)
|
||
(and (setq fn-type (quoted-function-p code))
|
||
(or (eq fn-type 'symbol)
|
||
(let ((free-var nil)
|
||
(*renames* nil)
|
||
(*in-oss-expr* nil))
|
||
(m-&-r (cadr code)
|
||
#'(lambda (c)
|
||
(when (and (variable-p c)
|
||
(not (assoc c *renames*)))
|
||
(push c free-var))
|
||
c))
|
||
(null free-var))))))
|
||
code))
|
||
|
||
(defun substitutable-destination (ret arg code)
|
||
(not (or (off-line-spot arg)
|
||
(contains-p (list (var arg)) (rets (fr arg)))
|
||
;;prevents weird declarations from appearing
|
||
(contains-p (list (var arg)) (dcls (fr arg)))
|
||
;;cheap check for not binding
|
||
(and (variable-p code) (contains-p (list code) (cddr (fr arg))))
|
||
(not (or (numberp code) (null code) (eq code T) (symbolp code)
|
||
(and (null (cdr (nxts ret)))
|
||
(not-contained-twice (list (var arg))
|
||
(list (prolog (fr arg))
|
||
(body (fr arg))
|
||
(epilog (fr arg))))))))))
|
||
|
||
;Splitting cuts up the graph at all of the correct places, and creates a
|
||
;lisp expression which, when evaluated will merge everything together.
|
||
;Things area done this way so that all of the splitting will happen
|
||
;before any of the merging. This makes error messages better and allows
|
||
;all the right code motion to happen easily.
|
||
; A throw is used to start all over again when recovering from an
|
||
;error, because it can be essential to restart from the top so that
|
||
;disconnected splitting will happen soon enough
|
||
|
||
(defun do-splitting (*graph*)
|
||
(loop
|
||
(reset-marks 0)
|
||
(let ((result nil) (error nil))
|
||
(setq error (catch :split
|
||
(setq result (non-oss-split *graph*))
|
||
nil))
|
||
(when (not error) (return result))
|
||
(case (car error)
|
||
(:isolation
|
||
(make-port-isolated (cadr error) (caddr error)))
|
||
(:connection
|
||
(make-disconnected (caddr error)))))))
|
||
|
||
;This takes a ret which is known not to be isolated and duplicates
|
||
;code in order to make the ret be isolated. In simple situations
|
||
;it does a pretty good job of duplicating minimum code.
|
||
|
||
(defun make-port-isolated (ret args)
|
||
(reset-marks 0)
|
||
(let ((to-follow (list (fr ret))))
|
||
(mark 2 (fr ret))
|
||
(loop (if (null to-follow) (return nil))
|
||
(let ((frag (pop to-follow)))
|
||
(dolist (a (args frag))
|
||
(let ((r (prv a)))
|
||
(when (not (marked-p 2 (fr r)))
|
||
(push (fr r) to-follow)
|
||
(mark 2 (fr r))))))))
|
||
(let ((to-follow (mapcar #'(lambda (a) (fr a)) args))
|
||
(followers nil) (*copied* nil))
|
||
(declare (special *copied*))
|
||
(loop (if (null to-follow) (return nil))
|
||
(let ((frag (pop to-follow)))
|
||
(when (not (marked-p 4 frag))
|
||
(mark 4 frag)
|
||
(push frag followers))
|
||
(dolist (r (rets frag))
|
||
(dolist (a (nxts r))
|
||
(push (fr a) to-follow)))))
|
||
(setq to-follow followers)
|
||
(loop (if (null to-follow) (return nil))
|
||
(let ((frag (pop to-follow)))
|
||
(dolist (a (args frag))
|
||
(when (and (oss-var-p a) (not (member a args)))
|
||
(let ((r (prv a)))
|
||
(when (not (marked-p 4 (fr r)))
|
||
(when (marked-p 2 (fr r))
|
||
(setq r (duplicate-frag r a)))
|
||
(push (fr r) to-follow)
|
||
(mark 4 (fr r))))))))))
|
||
|
||
(defun duplicate-frag (ret arg)
|
||
(declare (special *copied*))
|
||
(let* ((frag (fr ret)) new-frag new)
|
||
(when (not (setq new-frag (cdr (assoc frag *copied*))))
|
||
(setq new-frag (copy-fragment frag))
|
||
(push (cons frag new-frag) *copied*)
|
||
(let ((spot (member frag *graph*)))
|
||
(rplacd spot (cons new-frag (cdr spot))))
|
||
(mapc #'(lambda (old-arg new-arg)
|
||
(+dflow (prv old-arg) new-arg))
|
||
(args frag)
|
||
(args new-frag)))
|
||
(mapc #'(lambda (old-ret new-ret)
|
||
(when (eq old-ret ret)
|
||
(setq new new-ret)
|
||
(dolist (a (nxts old-ret))
|
||
(when (eq a arg)
|
||
(-dflow old-ret arg)
|
||
(+dflow new-ret arg)
|
||
(when (null (nxts old-ret))
|
||
(kill-ret old-ret))))))
|
||
(rets frag)
|
||
(rets new-frag))
|
||
new))
|
||
|
||
;This is prone to copying much too much.
|
||
|
||
(defun make-disconnected (frag)
|
||
(reset-marks 0)
|
||
(let ((to-follow (list frag)) (preceders nil) (*copied* nil))
|
||
(declare (special *copied*))
|
||
(loop (if (null to-follow) (return nil))
|
||
(let ((frag (pop to-follow)))
|
||
(dolist (a (args frag))
|
||
(when (oss-var-p a)
|
||
(let ((r (prv a)))
|
||
(when (not (marked-p 2 (fr r)))
|
||
(push (fr r) to-follow)
|
||
(mark 2 (fr r))))))))
|
||
;;preceders ends up in reverse dflow order
|
||
(dofrags (f 2) (push f preceders))
|
||
(mark 2 frag)
|
||
(dolist (f preceders)
|
||
(dolist (r (rets f))
|
||
(when (oss-var-p r)
|
||
(dolist (a (nxts r))
|
||
(when (not (marked-p 2 (fr a)))
|
||
(duplicate-frag r a))))))))
|
||
|
||
(eval-when (eval load compile)
|
||
(defmacro doing-splitting (&body body)
|
||
`(cond ((null (cdr *graph*)) (list 'quote (car *graph*)))
|
||
(T (reset-marks 1) (prog1 (progn . ,body) (reset-marks 0))))) )
|
||
|
||
;This breaks the expression up at points where there is no data flow
|
||
;between the subexpressions. Since the size of part1 is minimized it is
|
||
;known that it must be fully connected.
|
||
; This is called at several different points, in order to guaranttee that
|
||
;as much disconnected splitting as possible is always done before off line
|
||
;splitting is done. This also ensures that there cannot be any disconnected
|
||
;pieces when check-connected is called.
|
||
; This is called so often because it makes the eventual merging much
|
||
;better. In particular, the following expression cannot be merged
|
||
;correctly at all unless the off-line outputs are merge BEFORE the
|
||
;disconnected chuncks are merged.
|
||
|
||
;(lets* ((e1 (Elist '(1 -2 -4 3)))
|
||
; (e2 (Elist '(1 -2 -4 3)))
|
||
; (e3 (Elist '(1 -2 -4 3)))
|
||
; (w1 (TsplitF e2 #'plusp))
|
||
; ((nil x2) (TsplitF e3 #'plusp)))
|
||
; (list (Rlist (list e1 w1)) (Rlist (list w1 x2))))
|
||
|
||
;it is not at all easy to explain why this is the case. However, in
|
||
;this example the key problem is that an output ends up getting used two
|
||
;ways, once off-line and once not. Doing disconnected splitting early
|
||
;may not even fix the problem in general. However, it is just possible
|
||
;that the all termination points must connect to all outputs condition
|
||
;actually makes things work out ok.
|
||
|
||
(defun disconnected-split (next *graph*)
|
||
(doing-splitting
|
||
(multiple-value-bind (part1 part2)
|
||
(split-after (list (car *graph*))
|
||
#'(lambda (r a) (declare (ignore r a)) nil))
|
||
(cond ((null part2) (funcall next part1))
|
||
(T `(no-dflow-merge ,(funcall next part1)
|
||
,(disconnected-split next part2)))))))
|
||
|
||
;This finds internal non-oss dflows and splits the graph at that point.
|
||
;If *graph* is a complete expression, then the two subexpressions cannot
|
||
;have external series inputs or outputs. The size of part2 is minimized
|
||
;because it is felt that this will do a better job of equalizing the
|
||
;size of the two halves. However, this can cause part1 to have
|
||
;disconnected parts. Also, either half can contain more non-oss dflow.
|
||
;Therefore, both halves must be processed again by non-oss-split.
|
||
|
||
(defun non-oss-split (*graph*)
|
||
(doing-splitting
|
||
(block top
|
||
(dofrags (f)
|
||
(dolist (ret (rets f))
|
||
(when (not (oss-var-p ret))
|
||
(dolist (arg (nxts ret))
|
||
(when (marked-p 1 (fr arg))
|
||
(return-from top (do-non-oss-split ret arg)))))))
|
||
(disconnected-split #'off-line-input-split *graph*))))
|
||
|
||
(defun do-non-oss-split (ret arg)
|
||
(let ((frag1 (fr ret))
|
||
(frag2 (fr arg)))
|
||
(multiple-value-bind (part1 part2)
|
||
(split-before (list frag2)
|
||
#'(lambda (r a)
|
||
(declare (ignore r))
|
||
(not (oss-var-p a))))
|
||
(when (member frag1 part2)
|
||
(wrs 16 "Non-isolated non-oss data flow from:~%~S~%to:~%~S"
|
||
(code frag1) (code frag2))
|
||
(throw :split `(:isolation ,ret ,(nxts ret))))
|
||
`(non-oss-merge ,(non-oss-split part1)
|
||
,(non-oss-split part2)))))
|
||
|
||
;This looks for data flows going to off-line input ports. When
|
||
;splitting, it minimizes part1 so that the stuff that gets substituted
|
||
;in line will be as small as possible. Either part can still have off-line
|
||
;inputs in it. (Part1 may have to include some frags not yet scanned.)
|
||
; Note that even if the whole does not have any external oss ports, the
|
||
;two pieces will. Part2 will have an external off-line input (the one
|
||
;split on) and part1 will have an oss output which may be on-line.
|
||
;(It is possible that this output is used by a second off-line input
|
||
;<which is now still in part1 also> this forces complex merging cases
|
||
;to be handled.)
|
||
; Note dflow can fan out, but not fan in. For this reason, it is
|
||
;imperative that off-line inputs be split on before off-line outputs.
|
||
;Otherwise, one could fail to realize that an off-line input was not
|
||
;isolated. (It is very convenient the way that error checking works out.)
|
||
;Also note that since there is no fan in, input-splitting cannot cause
|
||
;either part to become disconnected.
|
||
|
||
(defun off-line-input-split (*graph*)
|
||
(doing-splitting
|
||
(block top
|
||
(dofrags (f)
|
||
(dolist (ret (rets f))
|
||
(dolist (arg (nxts ret))
|
||
(when (and (marked-p 1 (fr arg)) (off-line-spot arg))
|
||
(return-from top (do-off-line-input-split ret arg))))))
|
||
(off-line-output-split *graph*))))
|
||
|
||
(defun do-off-line-input-split (ret arg)
|
||
(let ((frag1 (fr ret))
|
||
(frag2 (fr arg)))
|
||
(multiple-value-bind (part1 part2)
|
||
(split-after (list frag1)
|
||
#'(lambda (r a)
|
||
(and (eq r ret) (eq a arg))))
|
||
(when (member frag2 part1)
|
||
(wrs 17.1 "Non-isolated oss input at the end of the ~
|
||
data flow from:~%~S~%to:~%~S"
|
||
(code frag1) (code frag2))
|
||
(throw :split `(:isolation ,ret ,(list arg))))
|
||
`(off-line-merge ,(off-line-input-split part1) ',ret
|
||
,(off-line-input-split part2) ',arg))))
|
||
|
||
|
||
;This looks for data flows going from off-line output ports. When
|
||
;splitting, it minimizes part2 so that the stuff that gets substituted
|
||
;in line will be as small as possible. This insures that part2 will be
|
||
;a connected piece. However, part1 may not be. (This means that on
|
||
;calls of this function, it cannot be assumed that the whole expression
|
||
;is connected. This is a reason why it is vital to minimize part2.)
|
||
;Either half can have more off-line outputs in it.
|
||
; Note that even if the whole does not have any external oss ports, the
|
||
;two pieces will. Part1 will have an external off-line output (the one
|
||
;split on) and part2 will have an on-line oss input.
|
||
|
||
(defun off-line-output-split (*graph*)
|
||
(doing-splitting
|
||
(block top
|
||
(dofrags (f)
|
||
(dolist (ret (rets f))
|
||
(when (off-line-spot ret)
|
||
(let ((args nil))
|
||
(dolist (arg (nxts ret))
|
||
(when (marked-p 1 (fr arg))
|
||
(pushnew arg args)))
|
||
(when args
|
||
(return-from top (do-off-line-output-split ret args)))))))
|
||
(check-connected *graph*))))
|
||
|
||
(defun do-off-line-output-split (ret args)
|
||
(let ((frag1 (fr ret))
|
||
(frags2 (mapcar #'(lambda (a) (fr a)) args)))
|
||
(multiple-value-bind (part1 part2)
|
||
(split-before frags2 #'(lambda (r a)
|
||
(declare (ignore a))
|
||
(eq r ret)))
|
||
(when (member frag1 part2)
|
||
(wrs 17.2 "Non-isolated oss output at the start of the ~
|
||
data flow from:~%~S~%to:~%~S"
|
||
(code frag1) (code (car frags2)))
|
||
(throw :split `(:isolation ,ret ,(nxts ret))))
|
||
`(off-line-merge
|
||
,(disconnected-split #'off-line-output-split part1)
|
||
',ret
|
||
,(disconnected-split #'off-line-output-split part2)
|
||
',(car args)))))
|
||
|
||
;This function checks that there is a dflow path from every termination
|
||
;point to every output of an on-line subexpression. It works by doing
|
||
;some fancy marker propagation.
|
||
|
||
(defun check-connected (*graph*)
|
||
(doing-splitting
|
||
(let ((counter 8.) (all-counters 0) (outputs nil) (terminations nil))
|
||
(dofrags (f 1)
|
||
(when (or (null (rets f))
|
||
(some #'(lambda (a) (not (marked-p 1 (fr a))))
|
||
(all-nxts f)))
|
||
(push f outputs))
|
||
(when (or (active-terminator-p f)
|
||
(some #'(lambda (r)
|
||
(and (not (marked-p 1 (fr r))) (oss-var-p r)))
|
||
(all-prvs f)))
|
||
(push (cons counter f) terminations)
|
||
(mark (+ 4 counter) f)
|
||
(setq all-counters (+ all-counters counter))
|
||
(setq counter (* 2 counter))))
|
||
(dofrags (f 5) ; 5 = 1+4
|
||
(let ((current-marks (logand -4 (marks f))))
|
||
(dolist (a (all-nxts f))
|
||
(when (marked-p 1 (fr a))
|
||
(mark current-marks (fr a))))))
|
||
(dolist (output outputs)
|
||
(when (not (marked-p all-counters output))
|
||
(dolist (entry terminations)
|
||
(when (not (marked-p (car entry) output))
|
||
(wrs 18 "No data flow path from the termination point: ~%~S~%~
|
||
to the output:~%~S" (code (cdr entry)) (code output))
|
||
(throw :split `(:connection ,(cdr entry) ,output)))))))
|
||
`(merge-on-line ',*graph*)))
|
||
|
||
;This splits the graph by dividing it into two parts (part1 and part2)
|
||
;so that to-follow is in part1, there is no data flow from part2 to
|
||
;part1 and all of the data flow from part1 to part2 satisfies the
|
||
;predicate CROSSABLE.
|
||
; The splitting is done by marker propogation (using the marker 2).
|
||
;The algorithm used has the effect of minimizing part1.
|
||
|
||
(defun split-after (to-follow crossable)
|
||
(dolist (f to-follow) (mark 2 f))
|
||
(loop (if (null to-follow) (return nil))
|
||
(let ((frag (pop to-follow)))
|
||
(dolist (a (args frag))
|
||
(let ((r (prv a)))
|
||
(when (= (marks (fr r)) 1) ;ie 1 but not 2
|
||
(push (fr r) to-follow)
|
||
(mark 2 (fr r)))))
|
||
(dolist (r (rets frag))
|
||
(dolist (a (nxts r))
|
||
(when (and (= (marks (fr a)) 1) ;ie 1 but not 2
|
||
(not (funcall crossable r a)))
|
||
(push (fr a) to-follow)
|
||
(mark 2 (fr a)))))))
|
||
(let ((part1 nil) (part2 nil))
|
||
(dofrags (f 1)
|
||
(if (marked-p 2 f) (push f part1) (push f part2)))
|
||
(reset-marks 0)
|
||
(values (nreverse part1) (nreverse part2))))
|
||
|
||
;This is almost exactly the same except propogation starts in part2 and part2
|
||
;is the part that is minimized.
|
||
|
||
(defun split-before (to-follow crossable)
|
||
(dolist (f to-follow) (mark 2 f))
|
||
(loop (if (null to-follow) (return nil))
|
||
(let ((frag (pop to-follow)))
|
||
(dolist (a (args frag))
|
||
(let ((r (prv a)))
|
||
(when (and (= (marks (fr r)) 1) ;ie 1 but not 2
|
||
(not (funcall crossable r a)))
|
||
(push (fr r) to-follow)
|
||
(mark 2 (fr r)))))
|
||
(dolist (r (rets frag))
|
||
(dolist (a (nxts r))
|
||
(when (= (marks (fr a)) 1) ;ie 1 but not 2
|
||
(push (fr a) to-follow)
|
||
(mark 2 (fr a)))))))
|
||
(let ((part1 nil) (part2 nil))
|
||
(dofrags (f 1)
|
||
(if (not (marked-p 2 f)) (push f part1) (push f part2)))
|
||
(reset-marks 0)
|
||
(values (nreverse part1) (nreverse part2))))
|
||
|
||
; When it comes to merging a pair of fragments together, there are four
|
||
;basic situations based on the data flow between the frags chosen
|
||
; 1- non-oss 2- no data flow 3- off-line 4- on-line.
|
||
;In the first three cases, things are arranged so that there is never
|
||
;any data flow except between the two fragments in question. In the
|
||
;fifth case, there can be other data flow, but it must be on-line
|
||
;data flow. A problem stems from the fact that there can be ports on
|
||
;the segments to which no internal data flow is attached---i.e., ports which
|
||
;are inputs and outputs of the expression as a whole or ports which
|
||
;are inputs and outputs of subexpressions created in earlier splittings
|
||
;of the graph. Even worse, for outputs, there can be additional data
|
||
;flow which goes to a frag in a different subexpression even though
|
||
;the output is also used in this subexpression. (The way things are
|
||
;split this can only happen with oss outputs.) Combining the frags
|
||
;together can require exterenally used oss ports to be modified.
|
||
; Two cases are always simple. If an extraneous input or output
|
||
;carries a non-series value, then there is never a problem. If it is
|
||
;an input than it must be available from the very start of computation
|
||
;and therefore will always be readable no matter how the frags are
|
||
;combined. If the port is an output, then it does not need to be
|
||
;available until after everything is done, and the strongly connected
|
||
;check insures that it will be eventually computed.
|
||
; Things are also basically simple if an extraneous input or output is
|
||
;off-line. In this situation, a specific marker says exactly where
|
||
;connected computation should be put, and this marker will always end
|
||
;up in an appropriate place no matter how the fragments are combined.
|
||
;The only thing which requires care is making sure that these
|
||
;markers stay at top level.
|
||
; One problem case however, is that it is possible for an off-line
|
||
;output to be used by an off-line input. This can cause a splitting
|
||
;to happen that ends up in a situation where an off-line input is used
|
||
;both internally and externally. If so, the output has to be
|
||
;preserved the first time it is used so that it can be used again.
|
||
; On the other hand, if an extraneous input or output is on-line,
|
||
;significant complexities can arise. If an extraneous port is
|
||
;on-line then it may have to be changed into an off-line port.
|
||
;Fortunately, things are arranged so that a graph is never split by
|
||
;breaking an on-line to on-line data flow. However, an on-line port
|
||
;can be on one end of a broken data flow. Nevertheless, most
|
||
;instances of extranious on-line ports come from weird lambdaS bodies.
|
||
;Except in simple situations extranious on-line ports are not
|
||
;supported unless they come from complete expressions.
|
||
; A key goal of the above is that every situation which can arise in
|
||
;a complete oss expression is properly dealt with. Beyond this
|
||
;certain weird situations in lambdaSs are dealt with while others
|
||
;generate error messages. You have to use the primitive definition
|
||
;facilities in this situation. (It should be noted that basically all of
|
||
;the problem cases in question are really quite rare indeed.)
|
||
|
||
; Consider the various problematical situations in detail
|
||
; 1- the frags to be combined are connected by non-oss dflow.
|
||
;The way graph splitting works insures that in a complete expression,
|
||
;both frags must be non-oss. There is no problem as long as at least
|
||
;one of the frags is non-oss. If one has series ports, it can be left totally
|
||
;alone. The other can be placed entirely in the prolog or epilog.
|
||
;The case of one non-oss frag is handled because it comes up often in
|
||
;lambdaS's and is easy to handle.
|
||
; If both frags have series ports, then the ports on one of the frags would
|
||
;have to become off-line. (A problem here is that it is not obvious
|
||
;which frag to do this to.) An error message is issued rather than
|
||
;make the combination.
|
||
|
||
(defun non-oss-merge (ret-frag arg-frag)
|
||
(when (not (non-oss-p ret-frag))
|
||
(when (not (non-oss-p arg-frag))
|
||
(ers 19 "LambdaS body too complex to merge into a single unit:~%~S~%~S"
|
||
(code ret-frag) (code arg-frag)))
|
||
(implicit-epilog arg-frag))
|
||
(handle-dflow ret-frag
|
||
#'(lambda (r a)
|
||
(and (eq (fr r) ret-frag) (eq (fr a) arg-frag))))
|
||
(merge-frags ret-frag arg-frag))
|
||
|
||
(defun implicit-epilog (frag)
|
||
(setf (epilog frag) (prolog frag))
|
||
(setf (prolog frag) nil)
|
||
frag)
|
||
|
||
; 2- There is no data flow between the frags.
|
||
;The way graph splitting works insures that in a complete expression,
|
||
;both frags must be non-oss. As in the case above, there is no problem
|
||
;as long as at least one of the frags is non-oss. Beyond that, since
|
||
;there is no data flow between the frags, things are still fine.
|
||
;(Non-oss and off-line are never a problem, and on-line inputs and
|
||
;outputs will run along nicely in phase when the frags are merged side
|
||
;by side.)
|
||
|
||
(defun no-dflow-merge (frag1 frag2)
|
||
(merge-frags frag1 frag2))
|
||
|
||
; 3- the frags to be combined are connected by an off-line dflow.
|
||
;(This may be from an on-line or off-line output to an on-line or
|
||
;off-line input.) Here things are quite complicated as indicated below.
|
||
; A- The ret is off-line and the arg is on-line
|
||
;There are two basic ways in which this can be handled.
|
||
; A1- The most straightforward way is to insert the arg frag into the
|
||
;off-line-spot in the ret-frag. This has the feature that it is very
|
||
;simple and allows on-line inputs and outputs of the ret-frag
|
||
;to remain unchanged. However, on-line inputs and outputs of the
|
||
;arg-frag are forced to become off-line.
|
||
; A2- The ret-frag is turned inside out and converted into an
|
||
;enumerator, which has on-line data flow to the arg-frag. This
|
||
;requires the use of a flag variable, and the makinf off-line of any
|
||
;on-line inputs or outputs of the ret-frag. However, it allows any
|
||
;extraneous inputs and outputs of the arg-frag to remain unchanged.
|
||
; If either of the two frags has no extraneous on-line ports, then the
|
||
;appropriate combination method above is used and everything works
|
||
;out great. If they both have extraneous on-line ports, then which
|
||
;every one has fewer of these ports has them changed to off-line
|
||
;ports and the appropriate process above is then applied.
|
||
; In either case, special care has to be taken to insure that the
|
||
;off-line output will still exist if it is used someplace other than
|
||
;in the arg-frag. (It is possible that it will exist, but will get
|
||
;changed to on-line. This does not cause confusion since the input it
|
||
;is connected to must be off-line, or the splitting which caused the
|
||
;difficultly in the first place would not have occured.)
|
||
; B- The ret is on-line and the arg is off-line. This case is
|
||
;closely analogous to the one above. Again, there are two basic ways
|
||
;to proceed.
|
||
; B1- The most straightforward way is to insert the ret frag into the
|
||
;off-line-spot in the arg-frag. This has the feature that it is very
|
||
;simple and allows all on-line inputs and outputs of the arg-frag
|
||
;to remain unchanged. However, on-line inputs and outputs of the
|
||
;ret-frag are forced to become off-line.
|
||
; B2- The arg-frag is turned inside out and converted into a
|
||
;reducer which receives on-line data flow from the ret-frag. This
|
||
;requires the use of a flag variable, and it forces off-line any
|
||
;extraneous on-line inputs or outputs of the arg-frag. However, it allows any
|
||
;extraneous inputs and outputs of the ret-frag to remain unchanged.
|
||
; If either of the two frags has no extraneous ports, then the
|
||
;appropriate combination method above is used and everything works
|
||
;out great. If the both have extraneous ports then which every has
|
||
;fewer has them changed to off-line and things proceed as above.
|
||
; C- the ret and arg are both off-line. Here it is
|
||
;not possible to simultaneously substitute the frags into each other.
|
||
;However, it is possible to combine them after A2 is applied to the
|
||
;ret-frag or B2 is applied to the arg-frag. Again this presents two
|
||
;options and it is possible to preserve either the extraneous ports of
|
||
;the ret-frag or the arg-frag, but not both.
|
||
; Note we have to be prepared for the general case more often than you might
|
||
;think, because the compination process can cause ports to become off-line
|
||
|
||
(defun off-line-merge (ret-frag ret arg-frag arg)
|
||
(handle-dflow (fr ret)
|
||
#'(lambda (r a)
|
||
(eq r ret) (eq (fr a) arg-frag)))
|
||
(let* ((ret-rating (count-on-line ret-frag))
|
||
(arg-rating (count-on-line arg-frag)))
|
||
(cond ((not (off-line-spot arg))
|
||
(if (> arg-rating ret-rating)
|
||
(convert-to-enumerator ret nil)
|
||
(substitute-in-output ret arg)))
|
||
((not (off-line-spot ret))
|
||
(if (and (> ret-rating arg-rating) (null (off-line-exit arg)))
|
||
(convert-to-reducer arg)
|
||
(substitute-in-input ret arg)))
|
||
(T (cond ((and (> ret-rating arg-rating) (null (off-line-exit arg)))
|
||
(convert-to-reducer arg)
|
||
(substitute-in-output ret arg))
|
||
(T (convert-to-enumerator ret (off-line-exit arg))
|
||
(substitute-in-input ret arg))))))
|
||
(maybe-de-oss (merge-frags ret-frag arg-frag)))
|
||
|
||
(defun find-on-line (syms)
|
||
(do ((s syms (cdr s)) (r nil))
|
||
((null s) (nreverse r))
|
||
(when (and (oss-var-p (car s)) (null (off-line-spot (car s))))
|
||
(push (car s) r))))
|
||
|
||
(defun count-on-line (frag)
|
||
(+ (length (find-on-line (args frag))) (length (find-on-line (rets frag)))))
|
||
|
||
(defun substitute-in-output (ret arg)
|
||
(let ((ret-frag (fr ret)) (arg-frag (fr arg)))
|
||
(make-ports-off-line arg-frag (off-line-exit arg))
|
||
(setf (body ret-frag)
|
||
(nsubst-inline (body arg-frag) (off-line-spot ret) (body ret-frag)
|
||
(nxts ret)))
|
||
(setf (body arg-frag) nil)))
|
||
|
||
(defun substitute-in-input (ret arg)
|
||
(let ((ret-frag (fr ret)) (arg-frag (fr arg)))
|
||
(make-ports-off-line ret-frag (off-line-exit arg))
|
||
(when (off-line-exit arg)
|
||
(dolist (a (args (fr ret)))
|
||
(if (and (oss-var-p a) (not (off-line-exit a)))
|
||
(setf (off-line-exit a) (off-line-exit arg))))
|
||
(nsubst (off-line-exit arg) `END (body ret-frag)))
|
||
(setf (body arg-frag)
|
||
(nsubst-inline (body ret-frag) (off-line-spot arg) (body arg-frag)))
|
||
(setf (body ret-frag) nil)))
|
||
|
||
(defun nsubst-inline (new-list old list &optional (save-spot nil))
|
||
(let ((tail (member old list)))
|
||
(cond (save-spot (rplacd tail (nconc new-list (cdr tail))))
|
||
(new-list (rplaca tail (car new-list))
|
||
(rplacd tail (nconc (cdr new-list) (cdr tail))))
|
||
((cdr tail) (rplaca tail (cadr tail))
|
||
(rplacd tail (cddr tail)))
|
||
(T (setq list (nbutlast list)))))
|
||
list)
|
||
|
||
(defun make-ports-off-line (frag off-line-exit)
|
||
(make-inputs-off-line frag off-line-exit)
|
||
(make-outputs-off-line frag))
|
||
|
||
(defun make-outputs-off-line (frag)
|
||
(dolist (out (find-on-line (rets frag)))
|
||
(let ((-X- (gensym "-X-")))
|
||
(setf (off-line-spot out) -X-)
|
||
(setf (body frag) `(,@(body frag) ,-X-)))))
|
||
|
||
(defun make-inputs-off-line (frag off-line-exit)
|
||
(dolist (in (find-on-line (args frag)))
|
||
(let ((-X- (gensym "-X-")))
|
||
(setf (off-line-spot in) -X-)
|
||
(setf (off-line-exit in) off-line-exit)
|
||
(setf (body frag) `(,-X- . ,(body frag))))))
|
||
|
||
(defun convert-to-enumerator (ret off-line-exit)
|
||
(let ((frag (fr ret)))
|
||
(make-ports-off-line frag off-line-exit)
|
||
(let* ((tail (member (off-line-spot ret) (body frag)))
|
||
(head (ldiff (body frag) tail))
|
||
(flag (gensym "FLAG-"))
|
||
(E (gensym "E-")))
|
||
(setf (off-line-spot ret) nil)
|
||
(cond ((null (cdr tail)) (setf (body frag) head))
|
||
(T (push flag (aux frag))
|
||
(push `(setq ,flag nil) (prolog frag))
|
||
(setf (body frag)
|
||
`((when (null ,flag) (setq ,flag T) (go ,E))
|
||
,@(cdr tail)
|
||
,E . ,head)))))
|
||
frag))
|
||
|
||
(defun convert-to-reducer (arg)
|
||
(let ((frag (fr arg)))
|
||
(make-outputs-off-line frag)
|
||
(let* ((tail (member (off-line-spot arg) (body frag)))
|
||
(head (ldiff (body frag) tail))
|
||
(flag (gensym "FLAG-"))
|
||
(M (gensym "M-"))
|
||
(N (gensym "N-")))
|
||
(push flag (aux frag))
|
||
(push `(setq ,flag nil) (prolog frag))
|
||
(setf (body frag)
|
||
`((if (null ,flag) (go ,M))
|
||
,N ,@(cdr tail)
|
||
,M ,@head
|
||
(when (null ,flag) (setq ,flag T) (go ,N)))))
|
||
frag))
|
||
|
||
; 4- The frags to be combined are connected by on-line data flow.
|
||
;here things are complicated because there can be a lot of frags.
|
||
;All of the internal data flow must be on-line. There may well be
|
||
;external on-line inputs and outputs. There may also be on-line
|
||
;outputs which are used both internally and externally. There may
|
||
;also be external off-line ports, but they cannot be used internaly.
|
||
;However, all of this is no problem. All of the on-line ports will
|
||
;stay on-line and the same for the off-line ones. The only which one
|
||
;has to be careful about is making sure that an on-line port which is
|
||
;used both internaly and externally does not go away.
|
||
|
||
(defun merge-on-line (*graph*) ;merge everything, all dflow is on-line.
|
||
(let ((frag nil))
|
||
(dofrags (f)
|
||
(handle-dflow f
|
||
#'(lambda (r a) (declare (ignore r))
|
||
(member (fr a) *graph*)))
|
||
(if (not frag) (setq frag f) (setq frag (merge-frags frag f))))
|
||
(maybe-de-oss frag)))
|
||
|
||
;This is used for the variable renaming part of all kinds of dflow.
|
||
;rets must be saved either if they have no dflow from them (they are
|
||
;outputs of the whole top level expression) or if there is a dflow to
|
||
;a frag which is not currently being dealt with.
|
||
|
||
(defun handle-dflow (source allowable-p)
|
||
(dolist (ret (rets source))
|
||
(let ((ret-killable (not (null (nxts ret)))))
|
||
(dolist (arg (nxts ret))
|
||
(cond ((not (funcall allowable-p ret arg)) (setq ret-killable nil))
|
||
(T (nsubst (var ret) (var arg) (fr arg))
|
||
(-dflow ret arg)
|
||
(-arg arg))))
|
||
(if ret-killable (-ret ret)))))
|
||
|
||
; TURNING A FRAG INTO CODE
|
||
|
||
;this takes a non-oss frag and makes it into a garden variety chunk of code.
|
||
;It assumes that it will never be called on a frag with an oss input.
|
||
|
||
(defun codify (frag)
|
||
(if *oss-tutorial-mode* (allow-oss-outputs frag))
|
||
(dolist (r (rets frag))
|
||
(if (oss-var-p r) (-ret r)))
|
||
(maybe-de-oss frag)
|
||
(let ((rets (mapcar #'(lambda (r) (var r)) (rets frag)))
|
||
(aux (aux frag))
|
||
(code (prolog frag)))
|
||
(when (wrappers frag)
|
||
(if (cdr code) (setq code (cons 'progn code)) (setq code (car code)))
|
||
(dolist (wrp (wrappers frag))
|
||
(setq code (funcall (eval wrp) code)))
|
||
(setq code (list code)))
|
||
(if (and rets (null (cdr rets)))
|
||
(setq rets (car rets))
|
||
(setq rets `(values . ,rets)))
|
||
(setq code (nconc code (list rets)))
|
||
(multiple-value-setq (aux code) (clean-code aux code))
|
||
(setq aux (sort aux #'(lambda (a b) (string-lessp (string a) (string b)))))
|
||
(if (dcls frag) (push `(declare . ,(clean-dcls aux (dcls frag))) code))
|
||
(setq code `(let ,aux . ,code))
|
||
(use-user-names aux code)
|
||
(setq *last-oss-loop* code)))
|
||
|
||
(defun use-user-names (aux loop)
|
||
(let ((alist nil))
|
||
(dolist (v aux)
|
||
(let ((u (cdr (assoc v *user-names*))))
|
||
(if (and u (not (contains-p (list u) loop)) (not (rassoc u alist)))
|
||
(push (cons v u) alist))))
|
||
(if alist (nsublis alist loop))))
|
||
|
||
;this takes an oss frag all of whose inputs and outputs are non-oss
|
||
;things and makes it into a non-oss frag.
|
||
|
||
(defun maybe-de-oss (frag)
|
||
(when (and (non-oss-p frag) (or (body frag) (epilog frag)))
|
||
(when (not (or *permit-non-terminating-oss-expressions*
|
||
(active-terminator-p frag)))
|
||
(wrs 15 "Non-terminating OSS expression:~%~S" (code frag)))
|
||
(let ((lab (gensym "L-")))
|
||
(setf (prolog frag)
|
||
`((tagbody ,@(prolog frag)
|
||
,lab ,@(body frag) (go ,lab)
|
||
END ,@(epilog frag)))))
|
||
(setf (body frag) nil)
|
||
(setf (epilog frag) nil)
|
||
(clean-labs frag (cdar (prolog frag))))
|
||
frag)
|
||
|
||
;This cleans out unneeded vars
|
||
;and turns (funcall #'name . args) into (name args).
|
||
;together with the in-line substitution which is performed when
|
||
;fragments are combined, this transformation allows macros to be used
|
||
;as the arguments of oss functions.
|
||
|
||
(defun clean-code (aux code)
|
||
(let* ((suspicious (not-contained-twice aux code))
|
||
(dead-aux (clean-code1 suspicious code)))
|
||
(clean-code3 code)
|
||
(values (set-difference aux dead-aux) code)))
|
||
|
||
(defun not-contained-twice (items thing)
|
||
(let ((found-once nil) (found-twice nil))
|
||
(labels ((look-at (tree)
|
||
(cond ((symbolp tree)
|
||
(let ((found (car (member tree items))))
|
||
(when found
|
||
(if (member found found-once)
|
||
(pushnew found found-twice)
|
||
(push found found-once)))))
|
||
(T (do ((tt tree (cdr tt)))
|
||
((not (consp tt)) nil)
|
||
(look-at (car tt)))))))
|
||
(look-at thing))
|
||
(set-difference items found-twice)))
|
||
|
||
(defun clean-code1 (suspicious code)
|
||
(let ((dead nil))
|
||
(labels ((clean-code2 (prev-parent parent code &aux var)
|
||
(tagbody
|
||
R (when (setq var (car (member (setq-p code) suspicious)))
|
||
(push var dead)
|
||
(rplaca parent (setq code (caddr code)))
|
||
(when (or (symbolp code) (constantp code))
|
||
(cond ((consp (cdr parent))
|
||
(rplaca parent (cadr parent))
|
||
(rplacd parent (cddr parent))
|
||
(setq code (car parent))
|
||
(go R)) ;do would skip the next element
|
||
(prev-parent (pop (cdr prev-parent)))))))
|
||
(when (consp code)
|
||
(clean-code2 nil code (car code))
|
||
(do ((tt code (cdr tt)))
|
||
((not (and (consp tt) (consp (cdr tt)))) nil)
|
||
(clean-code2 tt (cdr tt) (cadr tt))))))
|
||
(clean-code2 nil nil code) ;depends on code not being setq at top.
|
||
dead)))
|
||
|
||
(defun clean-code3 (code)
|
||
(cond ((not (consp code)) code)
|
||
(T (when (and (eq (car code) 'funcall)
|
||
(eq (quoted-function-p (cadr code)) 'symbol))
|
||
(rplaca code (cadadr code))
|
||
(rplacd code (cddr code)))
|
||
(do ((tt code (cdr tt)))
|
||
((not (consp tt)))
|
||
(clean-code3 (car tt))))))
|
||
|
||
;this cleans up type dcls and leaves other ones alone.
|
||
;the key problem is that there can end up being several type decls for the
|
||
;same variable when fragments are combined.
|
||
|
||
(proclaim '(special *type-info*))
|
||
|
||
(defun clean-dcls (aux dcls)
|
||
(let ((*type-info* (mapcar #'list aux))
|
||
(new-dcls nil))
|
||
(dolist (dcl dcls)
|
||
(let ((d (type-dcl-p dcl)))
|
||
(if (null d) (push dcl new-dcls)
|
||
(dolist (var (cdr d))
|
||
(when (variable-p var)
|
||
(process-type-dcl (car d) var))))))
|
||
(nconc (make-type-dcls) (nreverse new-dcls))))
|
||
|
||
(defun type-dcl-p (dcl)
|
||
(cond ((not (consp dcl)) nil)
|
||
((eq (car dcl) 'type) (cdr dcl))
|
||
((subtypep (car dcl) 'common) dcl)))
|
||
|
||
(defun process-type-dcl (type var)
|
||
(let ((entry (assoc var *type-info*)))
|
||
(when entry
|
||
(setf (cdr entry) (best-type (cdr entry) type)))))
|
||
|
||
(defun best-type (type1 type2)
|
||
(cond ((null type1) type2)
|
||
((eq type1 :notype) type1)
|
||
((subtypep type1 type2) type1)
|
||
((subtypep type2 type1) type2)
|
||
(T :notype)))
|
||
|
||
(defun make-type-dcls ()
|
||
(let ((dcls-by-type nil))
|
||
(dolist (entry (nreverse *type-info*)) ;to get lexical order right at end
|
||
(when (and (cdr entry) (not (eq (cdr entry) :notype)))
|
||
(let ((new-entry (assoc (cdr entry) dcls-by-type :test #'equal)))
|
||
(if (null new-entry)
|
||
(push (list (cdr entry) (car entry)) dcls-by-type)
|
||
(push (car entry) (cdr new-entry))))))
|
||
(mapcar #'(lambda (d) (cons 'type d)) dcls-by-type)))
|
||
|
||
;this gets rid of duplicate labs in a row.
|
||
(defun clean-labs (frag stmtns)
|
||
(let ((alist nil))
|
||
(do ((l stmtns (cdr l))) ((not (consp (cdr l))))
|
||
L (when (and (car l) (symbolp (car l))
|
||
(cadr l) (symbolp (cadr l)))
|
||
(push (cons (pop (cdr l)) (car l)) alist)
|
||
(go L)))
|
||
(nsublis alist frag)))
|
||
|
||
;this stuff supports tutorial-mode
|
||
|
||
(defvar *standard-readtable* nil)
|
||
(defvar *tutorial-readtable* nil)
|
||
|
||
(defun oss-tutorial-mode (&optional (T-or-nil T))
|
||
(when (null *tutorial-readtable*)
|
||
(setq *standard-readtable* *readtable*)
|
||
(setq *tutorial-readtable* (copy-readtable *readtable*))
|
||
(set-macro-character #\[ #'oss-reader nil *tutorial-readtable*)
|
||
(set-macro-character #\] #'oss-end-reader nil *tutorial-readtable*))
|
||
(setq *oss-tutorial-mode* T-or-nil)
|
||
(cond (*oss-tutorial-mode*
|
||
(setq *readtable* *tutorial-readtable*)
|
||
"TUTORIAL-MODE-ON")
|
||
(T (setq *readtable* *standard-readtable*)
|
||
"TUTORIAL-MODE-OFF")))
|
||
|
||
(defstruct (literal-oss (:print-function literal-oss-print))
|
||
contents)
|
||
|
||
(defun literal-oss-print (literal-oss stream level &aux first)
|
||
(declare (ignore level))
|
||
(setq first T)
|
||
(princ "[" stream)
|
||
(dolist (item (literal-oss-contents literal-oss))
|
||
(if first (setq first nil) (princ " " stream))
|
||
(if (eq item '|oss-elipsis|)
|
||
(princ "..." stream)
|
||
(prin1 item stream)))
|
||
(princ "]" stream))
|
||
|
||
(defun oss-end-reader (stream char)
|
||
(declare (ignore stream char))
|
||
'|end-of-literal-oss|)
|
||
|
||
(defun oss-reader (stream char)
|
||
(declare (ignore char))
|
||
(prog ((stuff nil) item)
|
||
L (setq item (read stream))
|
||
(if (eq item '|end-of-literal-oss|)
|
||
(return (make-literal-oss :contents (nreverse stuff))))
|
||
(push item stuff)
|
||
(go L)))
|
||
|
||
;This stuff is called by my-macroexpand in tutorial mode
|
||
|
||
(defun allow-literal-oss-inputs (thing)
|
||
(cond ((literal-oss-p thing)
|
||
(annotate thing
|
||
(funcallS-frag
|
||
(literal-frag
|
||
`(() ((items T)) (items list-ptr) () ()
|
||
((setq list-ptr ',(literal-oss-contents thing)))
|
||
((if (null list-ptr) (go END))
|
||
(setq items (pop list-ptr))) () ())) nil)))
|
||
(T thing)))
|
||
|
||
;this stuff is called by codify in tutorial mode
|
||
|
||
(defun allow-oss-outputs (frag)
|
||
(dolist (r (rets frag))
|
||
(when (oss-var-p r)
|
||
(convert-to-literal-oss r))))
|
||
|
||
(defun convert-to-literal-oss (ret)
|
||
(let* ((frag (fr ret))
|
||
(var (gensym "O-"))
|
||
(step `((push ,(var ret) ,var))))
|
||
(if (not (active-terminator-p frag))
|
||
(setq step (append step `((when (> (length ,var) 10)
|
||
(push '|oss-elipsis| ,var) (go END))))))
|
||
(push var (aux frag))
|
||
(push `(setq ,var nil) (prolog frag))
|
||
(push `(setq ,var (make-literal-oss :contents (nreverse ,var)))
|
||
(epilog frag))
|
||
(cond ((null (off-line-spot ret))
|
||
(setf (body frag) (append (body frag) step)))
|
||
(T (nsubst-inline step (off-line-spot ret) (body frag))))
|
||
(setf (oss-var-p ret) nil)
|
||
(setf (off-line-spot ret) nil)
|
||
(setf (var ret) var)
|
||
frag))
|
||
|
||
; SUB-PRIMITIVES FOR DEFINING COMPLEX FRAGS
|
||
|
||
(defmacro terminateS () ;important is not defmacroSed
|
||
"Subprimitive that causes the containing OSS function to terminate."
|
||
'(go END))
|
||
|
||
(defmacroS lambda-primitiveS (input-list output-list aux-list &body expr-list)
|
||
"Subprimitive for specifying literal OSS functions."
|
||
(declare (ignore input-list output-list aux-list expr-list))
|
||
(ers 21 "Lambda-primitiveS used in inappropriate context:~%~S" +call+))
|
||
|
||
(defmacroS prologS (&body expr-list)
|
||
"Subprimitive for defining computations that occur before an OSS function starts."
|
||
(declare (ignore expr-list))
|
||
(ers 22.1 "PrologS used in inappropriate context:~%~S" +call+))
|
||
|
||
(defmacroS epilogS (&body expr-list)
|
||
"Subprimitive for defining computations that occur after an OSS function stops."
|
||
(declare (ignore expr-list))
|
||
(ers 22.2 "EpilogS used in inappropriate context:~%~S" +call+))
|
||
|
||
(defmacroS next-inS (var &rest expr-list)
|
||
"Subprimitive for defining off-line inputs."
|
||
(declare (ignore var expr-list))
|
||
(ers 22.3 "Next-inS used in inappropriate context:~%~S" +call+))
|
||
|
||
(defmacroS next-outS (var)
|
||
"Subprimitive for defining off-line outputs."
|
||
(declare (ignore var))
|
||
(ers 22.4 "Next-outS used in inappropriate context:~%~S" +call+))
|
||
|
||
(defmacroS wrapS (function)
|
||
"Subprimitive for defining wrapping functions."
|
||
(declare (ignore function))
|
||
(ers 22.5 "WrapS used in inappropriate context:~%~S" +call+))
|
||
|
||
(defmacroS alterableS (var form)
|
||
"Specifies how to alter the LAMBDA-PRIMITIVES output VAR."
|
||
(declare (ignore var form))
|
||
(ers 22.6 "AlterableS used in inappropriate context:~%~S" +call+))
|
||
|
||
(defmacro defun-primitiveS (name input-list output-list aux-list
|
||
#-:GCLISP &environment #-:GCLISP *env*
|
||
&body expr-list)
|
||
"Subprimitive that defines an OSS function."
|
||
(let ((call (list* 'defun-primitiveS name input-list output-list
|
||
aux-list expr-list)))
|
||
(top-starting-oss-expr call
|
||
(setq expr-list (normalize-dcls expr-list T))
|
||
`(defmacroS ,name ,input-list
|
||
,@(if (stringp (car expr-list)) (list (pop expr-list)))
|
||
(funcallS-frag
|
||
(list->frag
|
||
',(frag->list
|
||
(process-lambda-primitiveS call
|
||
`(lambda-primitiveS . ,(cddr call)))))
|
||
(list . ,input-list))))))
|
||
|
||
(defun process-lambda-primitiveS (call lambda-primitiveS)
|
||
(starting-oss-expr call
|
||
(let* ((ins (cadr lambda-primitiveS))
|
||
(outs (caddr lambda-primitiveS))
|
||
(aux (cadddr lambda-primitiveS))
|
||
(forms (normalize-dcls (cddddr lambda-primitiveS)))
|
||
(oss-vars (cddadr (pop forms)))
|
||
(dcl (pop forms))
|
||
(frag (make-frag :code call)))
|
||
(dolist (v ins)
|
||
(when (not (lambda-variable-p v))
|
||
(ers 23.1 "Bad lambda-primitiveS input variable: ~S" v))
|
||
(let* ((var (gensym (root v)))
|
||
(arg (make-sym :var var
|
||
:oss-var-p (not (null (member v oss-vars))))))
|
||
(+arg arg frag)
|
||
(push (cons v arg) *renames*)))
|
||
(dolist (v aux)
|
||
(when (or (not (lambda-variable-p v)) (member v ins))
|
||
(ers 23.3 "Bad lambda-primitiveS aux variable: ~S" v))
|
||
(let ((var (gensym (root v))))
|
||
(push var (aux frag))
|
||
(push (cons v var) *renames*)))
|
||
(dolist (v outs)
|
||
(when (not (or (member v ins) (member v aux)))
|
||
(ers 23.2 "Bad lambda-primitiveS output variable: ~S" v))
|
||
(let* ((var (rename v))
|
||
(ret (make-sym :var var
|
||
:oss-var-p (not (null (member v oss-vars))))))
|
||
(+ret ret frag)))
|
||
(setf (dcls frag) (process-subforms-&-rename (cdr dcl)))
|
||
(let* ((alist nil) (new-forms nil))
|
||
(dolist (f forms)
|
||
(cond ((not (symbolp f)) (push f new-forms))
|
||
(T (let ((new (gensym (root f))))
|
||
(push (cons `(go ,f) `(go ,new)) alist)
|
||
(push new new-forms)))))
|
||
(when alist
|
||
(setq forms (sublis alist (nreverse new-forms) :test #'equal))))
|
||
|
||
(dolist (form forms)
|
||
(case (and (consp form) (car form))
|
||
(prologS
|
||
(setf (prolog frag)
|
||
(append (prolog frag)
|
||
(process-subforms-&-rename (cdr form)))))
|
||
(epilogS
|
||
(setf (epilog frag)
|
||
(append (epilog frag)
|
||
(process-subforms-&-rename (cdr form)))))
|
||
(wrapS (when (not (and (cdr form) (consp (cdr form))
|
||
(null (cddr form))
|
||
(quoted-function-p (cadr form))))
|
||
(ers 26 "Malformed wrapS call:~%~S" form))
|
||
(setf (wrappers frag) (append (wrappers frag) (cdr form))))
|
||
(next-inS
|
||
(let ((arg (cdr (assoc (cadr form) *renames*)))
|
||
(actions (process-subforms-&-rename (cddr form)))
|
||
(E (gensym "E-"))
|
||
(F (gensym "F-"))
|
||
(-X- (gensym "-X-")))
|
||
(when (not (and (member arg (args frag))
|
||
(oss-var-p arg)
|
||
(null (off-line-spot arg))))
|
||
(ers 24 "Malformed next-inS call:~%~S" form))
|
||
(setf (off-line-spot arg) -X-)
|
||
(if actions (setf (off-line-exit arg) E))
|
||
(setf (body frag) (append (body frag)
|
||
(if (null actions) (list -X-)
|
||
`(,-X- (go ,F) ,E ,@actions ,F))))))
|
||
(next-outS
|
||
(let* ((var (cdr (assoc (cadr form) *renames*)))
|
||
(ret (find-if #'(lambda (r) (eq var (var r))) (rets frag)))
|
||
(-X- (gensym "-X-")))
|
||
(when (not (and ret
|
||
(oss-var-p ret)
|
||
(null (off-line-spot ret))
|
||
(null (cddr form))))
|
||
(ers 25 "Malformed next-outS call:~%~S" form))
|
||
(setf (off-line-spot ret) -X-)
|
||
(setf (body frag) (append (body frag) (list -X-)))))
|
||
(alterableS
|
||
(let ((var (cdr (assoc (cadr form) *renames*)))
|
||
(setf-form (car (process-subforms-&-rename (cddr form)))))
|
||
(when (not (and (null (cdddr form))
|
||
(member (cadr form) outs)
|
||
(not (contains-p ins (caddr form)))
|
||
(not (assoc var (alterable frag)))))
|
||
(ers 27 "Malformed alterableS call:~%~S" form))
|
||
(setf (alterable frag)
|
||
(append (alterable frag) `((,var ,setf-form))))))
|
||
(otherwise
|
||
(setf (body frag)
|
||
(append (body frag)
|
||
(process-subforms-&-rename (list form)))))))
|
||
frag)))
|
||
|
||
; FUNCTIONS FOR DEALING WITH FEXPRS
|
||
|
||
;M-&-R takes in a piece of code. It assumes CODE is a semantic whole. Ie, it
|
||
;is something which could be evaled (as opposed to a disembodied cond clause).
|
||
;It scans over CODE macroexpanding all of the parts of it, and performing
|
||
;renames as specified by *RENAMES*. M-&-R puts entries on the variable
|
||
;*RENAMES* which block the renaming of bound variables.
|
||
; M-&-R also calls FN (if any) on every subpart of CODE (including the whole
|
||
;thing) which could possibly be evaluated. The result of consing together all
|
||
;of the results of FN is returned. Ie, the result is isomorphic to the input
|
||
;with each part replaced with what FN returned. This is done totally by
|
||
;copying. The input is not altered.
|
||
; In addition, m-&-R checks to see that the code isn't setqing variables
|
||
;it shouldn't be.
|
||
|
||
;In order to do the above, M-&-R has to be able to understand fexprs. It
|
||
;understands fexprs by having a description of each of the standard ones (see
|
||
;below). It will not work on certain weird ones.
|
||
; fexprs are understood by means of templates which are (usually circular)
|
||
;lists of function names. These fns are called in order to processes the
|
||
;various fields of the fexpr. The template can be a single fn in which case
|
||
;this fn is called to process the fexpr as a whole.
|
||
|
||
(eval-when (eval load compile)
|
||
(defmacro make-template (head rest)
|
||
`(let ((h (append ',head nil))
|
||
(r (append ',rest nil)))
|
||
(nconc h r r)))
|
||
|
||
(defmacro deft (name head rest)
|
||
`(setf (get ',name 'scan-template) (make-template ,head ,rest))) )
|
||
|
||
(proclaim '(special *being-setqed* ;T if in the assignment part of a setq
|
||
*fn*)) ;FN being scanned over code
|
||
;ugh an infinite loop ensues if you recompile these in symbolics
|
||
;version 6 when they are defconstants
|
||
(defvar *expr-template* (make-template (Q) (E)))
|
||
(defvar *eval-all-template* (make-template () (E)))
|
||
(defvar *fexprs-not-handled*
|
||
'(COMPILER-LET FLET LABELS MACROLET ;CL forms
|
||
DEF DEFF DEFPROP DEFUN LETF LETF* MACRO)) ;Lispm forms
|
||
|
||
(defun m-&-r (code &optional (*fn* nil))
|
||
(let ((*being-setqed* nil))
|
||
(m-&-r1 code)))
|
||
|
||
;on lispm '(lambda ...) macroexpands to (function (lambda ...)) ugh!
|
||
|
||
(defun my-macroexpand (code &aux (flag T))
|
||
(if *oss-tutorial-mode* (setq code (allow-literal-oss-inputs code)))
|
||
(loop
|
||
(if (or (null flag) (frag-p code)
|
||
(and (consp code) (symbolp (car code))
|
||
(get (car code) 'scan-template))) (return))
|
||
(multiple-value-setq (code flag) (macroexpand-1 code #-:GCLISP *env*)))
|
||
code)
|
||
|
||
(defun m-&-r1 (code)
|
||
(let ((*renames* *renames*) new)
|
||
(setq code (my-macroexpand code))
|
||
(when (and (symbolp code) (setq new (cdr (assoc code *renames*))))
|
||
(if (and *being-setqed* (sym-p new))
|
||
(ers 12 "The letS{*} variable ~S setqed." code))
|
||
(setq code new))
|
||
(if *fn* (setq code (funcall *fn* code)))
|
||
(if (not (consp code)) code
|
||
(m-&-r2 code
|
||
(let ((head (car code)))
|
||
(if (member head *fexprs-not-handled*)
|
||
(ers 20 "The form ~S not allowed in OSS expressions." head))
|
||
(if (symbolp head)
|
||
(or (get head 'scan-template) *expr-template*)
|
||
*eval-all-template*))))))
|
||
|
||
(defun m-&-r2 (code template)
|
||
(if (not (listp template)) (funcall template code)
|
||
(mapcar #'(lambda (tm c) (funcall tm c)) template code)))
|
||
|
||
;the following are the fns allowed in templates.
|
||
|
||
(defun Q (code) code)
|
||
(defun E (code) (m-&-r1 code))
|
||
(defun S (code) (let ((*being-setqed* T)) (m-&-r1 code)))
|
||
(defun L (code) (if (symbolp code) code (m-&-r1 code)))
|
||
(defun B (code) (bind-list code nil))
|
||
(defun B* (code) (bind-list code T))
|
||
(defun A (code) (arg-list code))
|
||
|
||
;This handles binding lists for PROG and LET.
|
||
|
||
(defun bind-list (args sequential &aux (pending nil))
|
||
(prog1 (mapcar #'(lambda (arg)
|
||
(let* ((val? (and (consp arg) (cdr arg)))
|
||
(new-val (if val? (m-&-r1 (cadr arg))))
|
||
(var (if (consp arg) (car arg) arg)))
|
||
(if sequential (push (list var) *renames*)
|
||
(push (list var) pending))
|
||
(if val? (list (car arg) new-val) arg)))
|
||
args)
|
||
(setq *renames* (append pending *renames*))))
|
||
|
||
(defun arg-list (args)
|
||
(mapcar #'(lambda (arg)
|
||
(let* ((vars (vars-of arg))
|
||
(val? (and (consp arg) (cdr arg)))
|
||
(new-val (if val? (m-&-r1 (cadr arg)))))
|
||
(setq *renames* (append (mapcar #'list vars) *renames*))
|
||
(if val? (list* (car arg) new-val (cddr arg)) arg)))
|
||
args))
|
||
|
||
;templates for special forms. Note that the following are not handled
|
||
; COMPILER-LET FLET LABELS MACROLET but must not macroexpand
|
||
|
||
(deft block (Q Q) (E))
|
||
(deft catch (Q) (E))
|
||
(deft function (Q Q) ())
|
||
(deft eval-when (Q Q) (E))
|
||
(deft go (Q Q) ())
|
||
(deft if (Q) (E))
|
||
(deft lambda (Q A) (E))
|
||
(deft let (Q B) (E))
|
||
(deft let* (Q B*) (E))
|
||
(deft multiple-value-call (Q) (E))
|
||
(deft multiple-value-prog1 (Q) (E))
|
||
(deft progn (Q) (E))
|
||
(deft progv (Q) (E))
|
||
(deft quote (Q Q) ())
|
||
(deft return-from (Q Q) (E))
|
||
(deft setq (Q) (S E))
|
||
(deft tagbody (Q) (L))
|
||
(deft the (Q Q) (E))
|
||
(deft throw (Q) (E))
|
||
(deft type (Q Q) (E))
|
||
(deft unwind-protect (Q) (E))
|
||
|
||
|
||
;These fix problems in Lucid/Sun Common Lisp.
|
||
;FLET and DECLARE in particular are macros there and messed things up
|
||
;by expanding at the wrong time.
|
||
|
||
(deft flet (Q) (E))
|
||
(deft declare (Q) (EX)) ;needed by Xerox CL
|
||
|
||
(deft compiler-let (Q) (E))
|
||
(deft macrolet (Q) (E))
|
||
(deft labels (Q) (E))
|
||
|
||
;this stuff is for the Lispm, it should not be needed for more real common
|
||
;lisps, but cannot hurt. (Many to many things are special forms on
|
||
;the lispm.)
|
||
|
||
(defun EX (code) (m-&-r2 code *expr-template*))
|
||
(defun EA (code) (m-&-r2 code *eval-all-template*))
|
||
(defun SA (code) (let ((*being-setqed* T)) (m-&-r2 code *eval-all-template*)))
|
||
(defun DOB (code) (do-bind code nil))
|
||
(defun DOB* (code) (do-bind code T))
|
||
|
||
(defun DO-bind (code sequential? &aux (pending nil))
|
||
(let* ((inits (mapcar
|
||
#'(lambda (e)
|
||
(cond ((and (consp e) (cdr e))
|
||
(prog1 (m-&-r1 (cadr e))
|
||
(if sequential?
|
||
(push (list (car e)) *renames*)
|
||
(push (list (car e)) pending))))
|
||
(T (if sequential?
|
||
(push (list e) *renames*)
|
||
(push (list e) pending)))))
|
||
code)))
|
||
(setq *renames* (append pending *renames*))
|
||
(let ((updates (mapcar #'(lambda (e)
|
||
(if (and (consp e) (cddr e))
|
||
(m-&-r1 (caddr e))))
|
||
code)))
|
||
(mapcar #'(lambda (e i u)
|
||
(cond ((not (consp e)) e)
|
||
((cddr e) (list (car e) i u))
|
||
((cdr e) (list (car e) i))
|
||
(T e)))
|
||
code inits updates))))
|
||
|
||
(defun WSLB (list)
|
||
(prog1 (EX list) (push (list (car list)) *renames*)))
|
||
|
||
;the following are just like exprs from the point of view of OSS.
|
||
; *CATCH AND INHIBIT-STYLE-WARNINGS MULTIPLE-VALUE-LIST
|
||
; MULTIPLE-VALUE-RETURN OR PROGW RETURN RETURN-LIST
|
||
; VARIABLE-BOUNDP VARIABLE-LOCATION VARIABLE-MAKUNBOUND
|
||
; AND and OR have to have templates because the lispm does something
|
||
; odd with the way it expands them. The value gets lost sometimes.
|
||
|
||
(deft AND (Q) (E)) ;this fixes an old lispm bug
|
||
(deft COMMENT () (Q))
|
||
(deft COND (Q) (EA))
|
||
(deft DO (Q DOB EA) (L)) ;no old DO
|
||
(deft DO* (Q DOB* EA) (L))
|
||
(deft DO-NAMED (Q Q DOB EA) (L))
|
||
(deft DO*-NAMED (Q Q DOB* EA) (L))
|
||
(deft GRINDEF () (Q))
|
||
(deft LET-IF (Q E B) (E))
|
||
(deft MULTIPLE-VALUE (Q SA) (E))
|
||
(deft OR (Q) (E)) ;this fixes an old lispm bug
|
||
(deft SETF (Q) (E)) ;fixes wierd interaction with lispm setf
|
||
(deft SETQ-GLOBALLY (Q) (S E))
|
||
(deft SIGNP (Q Q) (E))
|
||
(deft SSTATUS () (Q))
|
||
(deft STATUS () (Q))
|
||
(deft TRACE () (Q))
|
||
(deft UNTRACE () (Q))
|
||
(deft WITH-STACK-LIST (Q WSLB) (E))
|
||
(deft WITH-STACK-LIST* (Q WSLB) (E))
|
||
|
||
(defun multiple-value-bind-scan (body)
|
||
(let ((source (E (caddr body))) ;note order of eval
|
||
(bind (B (cadr body)))
|
||
(forms (EA (cdddr body))))
|
||
(list* (car body) bind source forms)))
|
||
|
||
(setf (get 'multiple-value-bind 'scan-template) #'multiple-value-bind-scan)
|
||
|
||
(defvar *prog-template* (make-template (Q B) (L)))
|
||
(defvar *named-prog-template* (make-template (Q Q B) (L)))
|
||
(defvar *prog*-template* (make-template (Q B*) (L)))
|
||
(defvar *named-prog*-template* (make-template (Q Q B*) (L)))
|
||
|
||
(defun prog-scan (body)
|
||
(ps0 body *prog-template* *named-prog-template*))
|
||
|
||
(defun prog*-scan (body)
|
||
(ps0 body *prog*-template* *named-prog*-template*))
|
||
|
||
(defun ps0 (body template named-template)
|
||
(if (and (cdr body) (cadr body) (symbolp (cadr body)))
|
||
(m-&-r2 body named-template)
|
||
(m-&-r2 body template)))
|
||
|
||
(setf (get 'prog 'scan-template) #'prog-scan)
|
||
(setf (get 'prog* 'scan-template) #'prog*-scan)
|
||
|
||
; SERIES FUNCTION LIBRARY
|
||
|
||
;Special form for defining series functions directly in the internal form.
|
||
;The various variables and the exit label must be unique in the body.
|
||
;The exit label must be END. Also everything is arranged just as it is
|
||
;in an actual frag structure.
|
||
|
||
(eval-when (eval load compile)
|
||
(defmacro defS (name arglist doc args rets aux dcls alt
|
||
prolog body epilog wrappers)
|
||
(let* ((vals (mapcar #'car args))
|
||
(syms aux)
|
||
(stuff (list args rets aux dcls alt prolog body epilog wrappers)))
|
||
(dolist (a args)
|
||
(push (car a) syms)
|
||
(if (written-p (car a) stuff)
|
||
(error "Malformed defS: Input written ~A" (car a))))
|
||
(dolist (r rets)
|
||
(if (not (member (car r) syms))
|
||
(error "Malformed defS: Free ret ~A" (car r))))
|
||
(if (eq arglist T) (setq arglist vals))
|
||
`(defmacroS ,name ,arglist ,@(if doc (list doc))
|
||
(funcallS-frag (literal-frag ',stuff) (list . ,vals)))))
|
||
|
||
(defun written-p (var thing)
|
||
(if (eq var (setq-p thing)) T
|
||
(do ((tt thing (cdr tt)))
|
||
((not (consp tt)) nil)
|
||
(if (written-p var (car tt)) (return T)))))
|
||
|
||
(defun setq-p (thing)
|
||
(and (eq-car thing 'setq)
|
||
(= (length thing) 3)
|
||
(cadr thing)))
|
||
|
||
(defun eq-car (thing item)
|
||
(and (consp thing) (eq (car thing) item))) )
|
||
|
||
(defmacroS Eoss (&rest expr-list)
|
||
"Creates a series of the results of the expressions."
|
||
(let ((spot (member :R expr-list)))
|
||
(when (and spot (null (cdr spot)))
|
||
(setq expr-list (ldiff expr-list spot))
|
||
(setq spot nil))
|
||
(cond ((null spot)
|
||
(let ((ins nil))
|
||
(dotimes (i (length expr-list) i)
|
||
(push (gensym "IN-") ins))
|
||
(funcallS-frag
|
||
(literal-frag
|
||
`(,(mapcar #'list ins) ((items T)) (items list-ptr) () ()
|
||
((setq list-ptr (list . ,ins)))
|
||
((if (null list-ptr) (go END))
|
||
(setq items (car list-ptr))
|
||
(setq list-ptr (cdr list-ptr))) () ()))
|
||
expr-list)))
|
||
((and (eq expr-list spot) (null (cddr spot)))
|
||
(funcallS-frag
|
||
(literal-frag
|
||
'(((expr)) ((expr T)) () () ()
|
||
() () () ()))
|
||
(list (cadr spot))))
|
||
(T (let ((first-part (ldiff expr-list spot))
|
||
(second-part (cdr spot))
|
||
(ins1 nil) (ins2 nil))
|
||
(dotimes (i (length first-part) i)
|
||
(push (gensym "IN-") ins1))
|
||
(dotimes (i (length second-part) i)
|
||
(push (gensym "IN-") ins2))
|
||
(funcallS-frag
|
||
(literal-frag
|
||
`(,(mapcar #'list (append ins1 ins2))
|
||
((items T)) (items list-ptr) () ()
|
||
((setq list-ptr
|
||
(let ((x (list . ,ins1))
|
||
(y (list . ,ins2)))
|
||
(nconc x y y))))
|
||
((setq items (pop list-ptr))) () ()))
|
||
(append first-part second-part)))))))
|
||
|
||
(defmacroS Eup (&rest args)
|
||
"Creates a series of numbers by counting up from START by :BY."
|
||
(let ((start 0) (by nil) (limit-type :none) (limit nil))
|
||
(when (and args (not (member (car args) '(:to :below :length :by))))
|
||
(setq start (pop args)))
|
||
(prog ()
|
||
L (if (null args) (return nil))
|
||
(when (and (eq (car args) :by) (null by) (cdr args))
|
||
(pop args)
|
||
(setq by (pop args))
|
||
(go L))
|
||
(when (and (member (car args) '(:to :below :length))
|
||
(eq limit-type :none) (cdr args))
|
||
(setq limit-type (pop args))
|
||
(setq limit (pop args))
|
||
(go L))
|
||
(ers 1.1 "Too many keywords specified in a call on Eup:~%~S" +call+))
|
||
(when (null by) (setq by 1))
|
||
(if (eq limit-type :none)
|
||
(funcallS-frag
|
||
(literal-frag
|
||
'(((start) (by)) ((numbers T)) (numbers) () ()
|
||
((setq numbers (- start by)))
|
||
((setq numbers (+ numbers by))) () ()))
|
||
(list start by))
|
||
(funcallS-frag
|
||
(literal-frag
|
||
(case limit-type
|
||
(:to '(((start) (to) (by)) ((numbers T)) (numbers) () ()
|
||
((setq numbers (- start by)))
|
||
((setq numbers (+ numbers by))
|
||
(if (> numbers to) (go END))) () ()))
|
||
(:below '(((start) (below) (by)) ((numbers T)) (numbers) () ()
|
||
((setq numbers (- start by)))
|
||
((setq numbers (+ numbers by))
|
||
(if (not (< numbers below)) (go END))) () ()))
|
||
(:length '(((start) (length) (by)) ((numbers T))
|
||
(numbers counter) () ()
|
||
((setq numbers (- start by)) (setq counter length))
|
||
((setq numbers (+ numbers by))
|
||
(if (not (plusp counter)) (go END))
|
||
(decf counter)) () ()))))
|
||
(list start limit by)))))
|
||
|
||
(defmacroS Edown (&rest args)
|
||
"Creates a series of numbers by counting down from START by :BY."
|
||
(let ((start 0) (by nil) (limit-type :none) (limit nil))
|
||
(when (and args (not (member (car args) '(:to :above :length :by))))
|
||
(setq start (pop args)))
|
||
(prog ()
|
||
L (if (null args) (return nil))
|
||
(when (and (eq (car args) :by) (null by) (cdr args))
|
||
(pop args)
|
||
(setq by (pop args))
|
||
(go L))
|
||
(when (and (member (car args) '(:to :above :length))
|
||
(eq limit-type :none) (cdr args))
|
||
(setq limit-type (pop args))
|
||
(setq limit (pop args))
|
||
(go L))
|
||
(ers 1.2 "Too many keywords specified in a call on Eup:~%~S" +call+))
|
||
(when (null by) (setq by 1))
|
||
(if (eq limit-type :none)
|
||
(funcallS-frag
|
||
(literal-frag
|
||
'(((start) (by)) ((numbers T)) (numbers) () ()
|
||
((setq numbers (+ start by)))
|
||
((setq numbers (- numbers by))) () ()))
|
||
(list start by))
|
||
(funcallS-frag
|
||
(literal-frag
|
||
(case limit-type
|
||
(:to '(((start) (to) (by)) ((numbers T)) (numbers) () ()
|
||
((setq numbers (+ start by)))
|
||
((setq numbers (- numbers by))
|
||
(if (< numbers to) (go END))) () ()))
|
||
(:above '(((start) (above) (by)) ((numbers T)) (numbers) () ()
|
||
((setq numbers (+ start by)))
|
||
((setq numbers (- numbers by))
|
||
(if (not (> numbers above)) (go END))) () ()))
|
||
(:length '(((start) (length) (by)) ((numbers T))
|
||
(numbers counter) () ()
|
||
((setq numbers (+ start by)) (setq counter length))
|
||
((setq numbers (- numbers by))
|
||
(if (not (plusp counter)) (go END))
|
||
(decf counter)) () ()))))
|
||
(list start limit by)))))
|
||
|
||
(defS Esublists (list &optional (end-test '#'endp))
|
||
"Creates a series of the sublists in a list."
|
||
((list) (end-test)) ((sublists T)) (sublists list-ptr) () ()
|
||
((setq list-ptr list))
|
||
((if (funcall end-test list-ptr) (go END))
|
||
(setq sublists list-ptr)
|
||
(setq list-ptr (cdr list-ptr))) () ())
|
||
|
||
(defS Elist (list &optional (end-test '#'endp))
|
||
"Creates a series of the elements in a list."
|
||
((list) (end-test)) ((elements T)) (elements list-ptr parent)
|
||
() ((elements (car parent)))
|
||
((setq list-ptr list))
|
||
((if (funcall end-test list-ptr) (go END))
|
||
(setq parent list-ptr)
|
||
(setq elements (car list-ptr))
|
||
(setq list-ptr (cdr list-ptr))) () ())
|
||
|
||
(defS Ealist (alist &optional (test '#'eql))
|
||
"Creates two series containing the keys and values in an alist."
|
||
((alist) (test)) ((keys T) (values T)) (alist-ptr keys values parent)
|
||
() ((keys (car parent)) (values (cdr parent)))
|
||
((setq alist-ptr alist))
|
||
(L (if (null alist-ptr) (go END))
|
||
(setq parent (car alist-ptr))
|
||
(setq alist-ptr (cdr alist-ptr))
|
||
(if (or (null parent)
|
||
(not (eq parent (assoc (car parent) alist :test test))))
|
||
(go L))
|
||
(setq keys (car parent))
|
||
(setq values (cdr parent))) () ())
|
||
|
||
(defS Eplist T
|
||
"Creates two series containing the indicators and values in a plist."
|
||
((plist)) ((indicators T) (values T)) (indicators values plist-ptr parent)
|
||
() ((indicators (car parent)) (values (cadr parent)))
|
||
((setq plist-ptr plist))
|
||
(L (if (null plist-ptr) (go END))
|
||
(setq parent plist-ptr)
|
||
(setq indicators (car plist-ptr))
|
||
(setq plist-ptr (cdr plist-ptr))
|
||
(setq values (car plist-ptr))
|
||
(setq plist-ptr (cdr plist-ptr))
|
||
(do ((ptr plist (cddr ptr)))
|
||
((eq (car ptr) indicators)
|
||
(if (not (eq ptr parent)) (go L))))) () ())
|
||
|
||
(defS Etree (tree &optional (leaf-test '#'atom))
|
||
"Creates a series of the nodes in a tree."
|
||
((tree) (leaf-test)) ((nodes T)) (nodes state) () ()
|
||
((setq state (list tree)))
|
||
((if (null state) (go END))
|
||
(setq nodes (car state))
|
||
(setq state (cdr state))
|
||
(when (not (funcall leaf-test nodes))
|
||
(do ((ns nodes (cdr ns))
|
||
(r nil (cons (car ns) r)))
|
||
((not (consp ns))
|
||
(setq state (nreconc r state)))))) () ())
|
||
|
||
(defS Efringe (tree &optional (leaf-test '#'atom))
|
||
"Creates a series of the leaves of a tree."
|
||
((tree) (leaf-test)) ((leaves T)) (leaves parent state)
|
||
() ((leaves (car parent)))
|
||
((setq state (list (list tree))))
|
||
(L (if (null state) (go END))
|
||
(setq leaves (car state))
|
||
(setq state (cdr state))
|
||
(setq parent leaves)
|
||
(setq leaves (car leaves))
|
||
(when (not (funcall leaf-test leaves))
|
||
(do ((ns leaves (cdr ns))
|
||
(r nil (cons ns r)))
|
||
((not (consp ns)) (setq state (nreconc r state))))
|
||
(go L))) () ())
|
||
|
||
(defmacroS Evector (vector &optional (indices (list 'Eup)))
|
||
"Creates a series of the elements in a vector."
|
||
(if (equal indices '(Eup))
|
||
(funcallS-frag
|
||
(literal-frag
|
||
'(((vector)) ((elements T)) (elements last index vect)
|
||
((type integer last index)) ((elements (aref vect index)))
|
||
((setq index -1)
|
||
(setq last (length vector))
|
||
(setq vect vector))
|
||
((incf index)
|
||
(if (not (< index last)) (go END))
|
||
(setq elements (aref vector index))) () ()))
|
||
(list vector))
|
||
(funcallS-frag
|
||
(literal-frag
|
||
'(((vector) (indices T)) ((elements T)) (elements last vect index)
|
||
((type integer last index)) ((elements (aref vect index)))
|
||
((setq last (length vector)) (setq vect vector))
|
||
((if (not (< indices last)) (go END))
|
||
(setq index indices)
|
||
(setq elements (aref vector indices))) () ()))
|
||
(list vector indices))))
|
||
|
||
(defS Esequence (sequence &optional (indices (list 'Eup)))
|
||
"Creates a series of the elements in a sequence."
|
||
((sequence) (indices T)) ((elements T)) (elements last seq index)
|
||
() ((elements (elt seq index)))
|
||
((setq last (length sequence)) (setq seq sequence))
|
||
((if (not (< indices last)) (go END))
|
||
(setq index indices)
|
||
(setq elements (elt sequence indices))) () ())
|
||
|
||
(defmacroS Efile (name)
|
||
"Creates a series of the forms in the file named NAME."
|
||
(let ((file (gensym "FILE-")))
|
||
(funcallS-frag
|
||
(literal-frag
|
||
`(() ((items T)) (items) () ()
|
||
()
|
||
((if (eq (setq items (read ,file nil ,file)) ,file) (go END))) ()
|
||
(#'(lambda (code)
|
||
(list 'with-open-file
|
||
'(,file ,name :direction :input)
|
||
code)))))
|
||
nil)))
|
||
|
||
#-lispm
|
||
(defS Ehash T
|
||
"Creates two series containing the keys and values in a hash table."
|
||
((table)) ((keys T) (values T)) (keys values list-ptr) () ()
|
||
((setq list-ptr nil)
|
||
(maphash #'(lambda (key val) (push (cons key val) list-ptr)) table))
|
||
((if (null list-ptr) (go END))
|
||
(setq keys (caar list-ptr))
|
||
(setq values (cdar list-ptr))
|
||
(setq list-ptr (cdr list-ptr))) () ())
|
||
|
||
#+lispm ;see hash-elements loop code
|
||
(defS Ehash T
|
||
"Creates two series containing the keys and values in a hash table."
|
||
((table)) ((keys T) (values T)) (state keys values) () ()
|
||
((setq state nil))
|
||
((if (not (multiple-value-setq (state keys values)
|
||
(si:send table :next-element state)))
|
||
(go END))) ()
|
||
(#'(lambda (c) `(si:inhibit-gc-flips ,c))))
|
||
|
||
#-lispm
|
||
(defS Esymbols (&optional (package nil))
|
||
"Creates a series of the symbols in PACKAGE."
|
||
((package)) ((symbols T)) (symbols list-ptr) () ()
|
||
((setq list-ptr nil)
|
||
(do-symbols (s (or package *package*)) (push s list-ptr)))
|
||
((if (null list-ptr) (go END))
|
||
(setq symbols (car list-ptr))
|
||
(setq list-ptr (cdr list-ptr))) () ())
|
||
|
||
#+lispm ;see do-symbols
|
||
(defS Esymbols (&optional (package nil))
|
||
"Creates a series of the symbols in PACKAGE."
|
||
((package)) ((symbols T)) (index state symbols) () ()
|
||
((multiple-value-setq (index symbols state)
|
||
(si:loop-initialize-mapatoms-state (or package *package*) nil)))
|
||
((if (multiple-value-setq (nil index symbols state)
|
||
(si:loop-test-and-step-mapatoms index symbols state))
|
||
(go END))) () ())
|
||
|
||
(defmacroS EnumerateF (init step &optional (test nil test-p))
|
||
"Creates a series by applying STEP to INIT until TEST returns non-null."
|
||
(if test-p
|
||
(funcallS-frag
|
||
(literal-frag
|
||
'(((init) (step) (test)) ((items T)) (items state) () ()
|
||
((setq state init))
|
||
((cond ((funcall test state) (go END))
|
||
(T (setq items state)
|
||
(setq state (funcall step state))))) () ()))
|
||
(list init step test))
|
||
(funcallS-frag
|
||
(literal-frag
|
||
'(((init) (step)) ((items T)) (items state) () ()
|
||
((setq state init))
|
||
((setq items state state (funcall step state))) () ()))
|
||
(list init step))))
|
||
|
||
(defS Enumerate-inclusiveF T
|
||
"Creates a series containing one more element than EnumerateF."
|
||
((init) (step) (test)) ((items T)) (items state done) () ()
|
||
((setq done nil) (setq state init))
|
||
((if done (go END))
|
||
(setq done (funcall test state))
|
||
(setq items state)
|
||
(if (not done) (setq state (funcall step state)))) () ())
|
||
|
||
(defmacroS Tprevious (items &optional (default nil) (amount 1))
|
||
"Shifts ITEMS to the right by AMOUNT inserting DEFAULT."
|
||
(if (eql amount 1)
|
||
(funcallS-frag
|
||
(literal-frag
|
||
'(((items T) (default)) ((shifted-items T)) (shifted-items state)
|
||
() ()
|
||
((setq state default))
|
||
((setq shifted-items state) (setq state items)) () ()))
|
||
(list items default))
|
||
(funcallS-frag
|
||
(literal-frag
|
||
'(((items T) (default) (amount)) ((shifted-items T))
|
||
(shifted-items ring) () ()
|
||
((setq ring (make-list (1+ amount) :initial-element default))
|
||
(nconc ring ring))
|
||
((setf (car ring) items)
|
||
(setq ring (cdr ring))
|
||
(setq shifted-items (car ring))) () ()))
|
||
(list items default amount))))
|
||
|
||
(defmacroS Tlatch (items &key (after nil) (before nil)
|
||
(pre nil pre?) (post nil post?))
|
||
"Modifies a series before or after a latch point."
|
||
(when (and after before)
|
||
(ers 1.3 "Too many keywords specified in call on Tlatch:~%~S" +call+))
|
||
(if (not (or before after)) (setq after 1))
|
||
(if (null pre?) (setq post? T))
|
||
(funcallS-frag
|
||
(literal-frag
|
||
`(((items T) (for) ,@(if pre? '((pre T))) ,@(if post? '((post T))))
|
||
((masked-items T)) (masked-items state) () ()
|
||
((setq state for))
|
||
((cond (,@(if before
|
||
'((and (plusp state)
|
||
(or (null items)
|
||
(not (zerop (setq state (1- state)))))))
|
||
'((plusp state)
|
||
(if items (decf state))))
|
||
(setq masked-items ,(if pre? 'pre 'items)))
|
||
(T (setq masked-items ,(if post? 'post 'items))))) () ()))
|
||
`(,items ,(or before after)
|
||
,@(if pre? (list pre)) ,@(if post? (list post)))))
|
||
|
||
(defS Tuntil T
|
||
"Returns ITEMS up to, but not including, the first non-null element of BOOLS."
|
||
((bools T) (items T)) ((items T)) () () ()
|
||
() ((if bools (go END))) () ())
|
||
|
||
(defS TuntilF T
|
||
"Returns ITEMS up to, but not including, the first element which satisfies PRED."
|
||
((pred T) (items T)) ((items T)) () () ()
|
||
() ((if (funcall pred items) (go END))) () ())
|
||
|
||
(defmacroS Tcotruncate (items &rest more-items)
|
||
"Truncates all the inputs to the length of the shortest input."
|
||
(let ((frag (make-frag))
|
||
(stuff (cons items more-items)))
|
||
(dotimes (i (length stuff) i)
|
||
(let ((var (gensym "CT-")))
|
||
(+arg (make-sym :var var :oss-var-p T) frag)
|
||
(+ret (make-sym :var var :oss-var-p T) frag)))
|
||
(funcalls-frag frag stuff)))
|
||
|
||
(defmacroS TmapF (function &rest items-list)
|
||
"Maps FUNCTION over the input series."
|
||
(do-TmapF function items-list))
|
||
|
||
(defun do-TmapF (function items-list)
|
||
(let ((frag (make-frag))
|
||
(params nil)
|
||
(retvar (gensym "ITEMS-"))
|
||
(fn (gensym "FUNCTION-")))
|
||
(+arg (make-sym :var fn) frag)
|
||
(+ret (make-sym :var retvar :oss-var-p T) frag)
|
||
(setf (aux frag) (list retvar))
|
||
(dotimes (i (length items-list) i)
|
||
(let ((var (gensym "M-")))
|
||
(push var params)
|
||
(+arg (make-sym :var var :oss-var-p T) frag)))
|
||
(setf (body frag)
|
||
`((setq ,retvar (funcall ,fn . ,(nreverse params)))))
|
||
(funcalls-frag frag (cons function items-list))))
|
||
|
||
(defmacroS TscanF (&rest arg-list)
|
||
"Computes cumulative values by applying FUNCTION to the elements of ITEMS."
|
||
(if (= (length arg-list) 3)
|
||
(funcallS-frag
|
||
(literal-frag
|
||
'(((init) (function) (items T)) ((results T)) (results) () ()
|
||
((setq results init))
|
||
((setq results (funcall function results items))) () ()))
|
||
arg-list)
|
||
(funcallS-frag
|
||
(literal-frag
|
||
'(((function) (items T)) ((results T)) (first results) () ()
|
||
((setq first T))
|
||
((if first (setq first nil results items)
|
||
(setq results (funcall function results items)))) () ()))
|
||
arg-list)))
|
||
|
||
(defS Tremove-duplicates (Oitems &optional (comparitor '#'eql))
|
||
"Removes the duplicate elements from a series."
|
||
((Oitems T -X-) (comparitor)) ((Oitems T)) (seen) () ()
|
||
((setq seen nil))
|
||
(L -X-
|
||
(if (member Oitems seen :test comparitor) (go L))
|
||
(push Oitems seen)) () ())
|
||
|
||
(defS Tchunk T
|
||
"Creates a series of lists of length AMOUNT of non-overlapping subseries of OITEMS."
|
||
((amount) (Oitems T -X-)) ((lists T)) (lists i state) () ()
|
||
((setq state nil) (setq i amount))
|
||
(L -X-
|
||
(decf i)
|
||
(push Oitems state)
|
||
(if (plusp i) (go L))
|
||
(setq lists (nreverse state))
|
||
(setq state nil) (setq i amount)) () ())
|
||
|
||
(defS Twindow T
|
||
"Creates a series of lists of length AMOUNT of successive overlapping subseries."
|
||
((amount) (Oitems T -X-)) ((lists T)) (lists ring count) () ()
|
||
((setq ring (make-list amount))
|
||
(setq count amount)
|
||
(nconc ring ring))
|
||
(L -X-
|
||
(decf count)
|
||
(setq ring (cdr ring))
|
||
(setf (car ring) Oitems)
|
||
(if (plusp count) (go L))
|
||
(let ((spot (cdr ring))) ;Avoids bug in Dec CL.
|
||
(rplacd ring nil)
|
||
(setq lists (copy-list spot))
|
||
(rplacd ring spot))) () ())
|
||
|
||
(defS Tpositions (Obools)
|
||
"Returns a series of the positions of non-null elements in OBOOLS."
|
||
((Obools T -X-)) ((index T)) (index) () ()
|
||
((setq index -1))
|
||
(L -X- (incf index) (if (not Obools) (go L))) () ())
|
||
|
||
(defS Tmask T
|
||
"Creates a series continuing T in the indicated positions."
|
||
((Omonotonic-indices T -X- D)) ((bools T)) (bools index) () ()
|
||
((setq index -1 bools T))
|
||
( (if (not bools) (go F))
|
||
-X- (go F) D (setq index nil)
|
||
F (setq bools (and index (= (progn (incf index) index)
|
||
Omonotonic-indices)))) () ())
|
||
|
||
(defmacroS Tselect (bools &optional (items nil items-p))
|
||
"Selects the elements of ITEMS corresponding to non-null elements of BOOLS."
|
||
(if items-p
|
||
(funcallS-frag
|
||
(literal-frag
|
||
'(((bools T) (items T)) ((items T -X-)) () () ()
|
||
() ((if (not bools) (go F)) -X- F) () ()))
|
||
(list bools items))
|
||
(funcallS-frag
|
||
(literal-frag
|
||
'(((bools T -X-)) ((bools T)) () () ()
|
||
() (L -X- (if (not bools) (go L))) () ()))
|
||
(list bools))))
|
||
|
||
(defS TselectF T
|
||
"Selects the elements of ITEMS for which PRED is non-null."
|
||
((pred) (Oitems T -X-)) ((Oitems T)) () () ()
|
||
() (L -X- (if (not (funcall pred Oitems)) (go L))) () ())
|
||
|
||
(defS Texpand (bools Oitems &optional (default nil))
|
||
"Spreads the elements of ITEMS out into the indicated positions."
|
||
((bools T) (Oitems T -X-) (default)) ((items T)) (items) () ()
|
||
()
|
||
((when (not bools) (setq items default) (go F))
|
||
-X- (setq items Oitems)
|
||
F) () ())
|
||
|
||
(defmacroS Tsubseries (Oitems start &optional (below nil))
|
||
"Returns the elements of OITEMS from START up to, but not including, BELOW."
|
||
(if below
|
||
(funcallS-frag
|
||
(literal-frag
|
||
'(((items T -X-) (start) (below)) ((items T)) (index) () ()
|
||
((setq index -1))
|
||
(LP -X-
|
||
(incf index)
|
||
(if (not (< index below)) (go END))
|
||
(if (< index start) (go LP))) () ()))
|
||
(list Oitems start below))
|
||
(funcallS-frag
|
||
(literal-frag
|
||
'(((items T -X-) (start)) ((items T)) (index) () ()
|
||
((setq index -1))
|
||
(LP -X-
|
||
(incf index)
|
||
(if (< index start) (go LP))) () ()))
|
||
(list Oitems start))))
|
||
|
||
(defS Tmerge T "Merges two series into one."
|
||
((Oitems1 T -X1- F1) (Oitems2 T -X2- F2) (comparator)) ((items T))
|
||
(items need1 need2) () ()
|
||
((setq need1 1 need2 1))
|
||
( (if (not (plusp need1)) (go F1))
|
||
(setq need1 -1)
|
||
-X1-
|
||
(setq need1 0)
|
||
F1 (if (not (plusp need2)) (go F2))
|
||
(setq need2 -1)
|
||
-X2-
|
||
(setq need2 0)
|
||
F2 (cond ((and (minusp need1) (minusp need2)) (go END))
|
||
((minusp need1) (setq items Oitems2) (setq need2 1))
|
||
((minusp need2) (setq items Oitems1) (setq need1 1))
|
||
((funcall comparator Oitems1 Oitems2)
|
||
(setq items Oitems1) (setq need1 1))
|
||
(T (setq items Oitems2) (setq need2 1)))) () ())
|
||
|
||
(defS Tlastp T
|
||
"Determines which element of the input is the last."
|
||
((Oitems T -X- F)) ((bools T) (items T)) (bools items started) () ()
|
||
((setq started nil) (setq bools nil))
|
||
( (if bools (go END))
|
||
L (setq items Oitems)
|
||
-X-
|
||
(when (not started) (setq started T) (go L))
|
||
(go D)
|
||
F (if (not started) (go END))
|
||
(setq bools T)
|
||
D) () ())
|
||
|
||
(defmacroS Tconcatenate (Oitems1 Oitems2 &rest more-Oitems) ;fix!
|
||
"Concatenates two or more series end to end."
|
||
(let (args body (len (+ 2 (length more-Oitems))))
|
||
(dotimes (i (1- len))
|
||
(let ((in (gensym "I-"))
|
||
(spot (gensym "-X-"))
|
||
(exit (gensym "E-"))
|
||
(skip (gensym "F-")))
|
||
(push (list in T spot exit) args)
|
||
(setq body (nconc body `((if (not (= state ,i)) (go ,skip))
|
||
,spot (setq items ,in) (go D)
|
||
,exit (incf state) ,skip)))))
|
||
(let ((in (gensym "I-"))
|
||
(spot (gensym "-X-")))
|
||
(push (list in T spot) args)
|
||
(setq body (nconc body `(,spot (setq items ,in) D))))
|
||
(funcallS-frag
|
||
(literal-frag
|
||
`(,(reverse args) ((items T)) (items state) () ()
|
||
((setq state 0)) ,body () ()))
|
||
(list* Oitems1 Oitems2 more-Oitems))))
|
||
|
||
(defmacroS Tsplit (items bools &rest more-bools)
|
||
"Divides a series into multiple outputs based on BOOLS."
|
||
(do-Tsplit items (cons bools more-bools) T))
|
||
|
||
(defmacroS TsplitF (items pred &rest more-pred)
|
||
"Divides a series into multiple outputs based on PRED."
|
||
(do-Tsplit items (cons pred more-pred) nil))
|
||
|
||
(defun do-Tsplit (items stuff bools-p)
|
||
(let ((frag (make-frag))
|
||
(ivar (gensym "ITEMS-"))
|
||
(D (gensym "D-")))
|
||
(+arg (make-sym :var ivar :oss-var-p T) frag)
|
||
(dotimes (i (length stuff) i)
|
||
(let ((var (gensym "B-"))
|
||
(-X- (gensym "-X-"))
|
||
(S (gensym "S-")))
|
||
(+arg (make-sym :var var :oss-var-p bools-p) frag)
|
||
(+ret (make-sym :var ivar :oss-var-p T :off-line-spot -X-) frag)
|
||
(setf (body frag)
|
||
`(,@(body frag)
|
||
(if (not ,(if bools-p var `(funcall ,var ,ivar))) (go ,S))
|
||
,-X-
|
||
(go ,D)
|
||
,S ))))
|
||
(let ((-X- (gensym "-X-")))
|
||
(+ret (make-sym :var ivar :oss-var-p T :off-line-spot -X-) frag)
|
||
(setf (body frag)
|
||
`(,@(body frag)
|
||
,-X- ,D)))
|
||
(funcalls-frag frag (cons items stuff))))
|
||
|
||
(defmacroS TconcatenateF (enumerator Oitems)
|
||
"Concatenates the results of applying ENUMERATOR to the elements of OITEMS."
|
||
(let* ((in (gensym "IN-"))
|
||
(enum-form `(lambdaS (,in) (funcallS ,enumerator ,in)))
|
||
(enum (process-lambdaS enum-form enum-form))
|
||
(flag (gensym "FLAG-"))
|
||
(-X- (gensym "-X-"))
|
||
(E (gensym "E-"))
|
||
(C (gensym "C-")))
|
||
(when (or (non-oss-p enum) (not (active-terminator-p enum))
|
||
(not (rets enum)) (not (oss-var-p (car (rets enum))))
|
||
(epilog enum) (wrappers enum))
|
||
(ers 2 "Invalid enumerator arg to TconcatenateF:~%~S" enumerator))
|
||
(push flag (aux enum))
|
||
(setf (oss-var-p (car (args enum))) T)
|
||
(setf (off-line-spot (car (args enum))) -X-)
|
||
(nsubst E 'END enum)
|
||
(setf (body enum)
|
||
`( (if ,flag (go ,C) (setq ,flag T))
|
||
,E ,-X-
|
||
,@(prolog enum)
|
||
,C ,@(body enum)))
|
||
(setf (prolog enum) `((setq ,flag nil)))
|
||
(annotate +call+ (funcallS-frag enum (list Oitems)))))
|
||
|
||
(defS Rlist T
|
||
"Combines the elements of ITEMS together into a list."
|
||
((items T)) ((the-list)) (the-list tail) () ()
|
||
((setq the-list nil) (setq tail nil))
|
||
((if (null the-list)
|
||
(setq the-list (setq tail (list items)))
|
||
(rplacd tail (setq tail (list items)))))
|
||
() ())
|
||
|
||
(defS Rbag T
|
||
"Combines the elements of ITEMS together into an unordered list."
|
||
((items T)) ((list)) (list) () ()
|
||
((setq list nil)) ((setq list (cons items list))) () ())
|
||
|
||
(defS Rappend T
|
||
"Appends the elements of LISTS together into a single list."
|
||
((lists T)) ((list)) (list end) () ()
|
||
((setq end nil) (setq list nil))
|
||
((when lists
|
||
(let ((copy (copy-list lists)))
|
||
(if end (setf (cdr (last end)) copy))
|
||
(setq end copy)
|
||
(if (null list) (setq list copy))))) () ())
|
||
|
||
(defS Rnconc T
|
||
"Destructively appends the elements of LISTS together into a single list."
|
||
((lists T)) ((list)) (list end) () ()
|
||
((setq end nil) (setq list nil))
|
||
((when lists
|
||
(if end (setf (cdr (last end)) lists))
|
||
(setq end lists)
|
||
(if (null list) (setq list lists)))) () ())
|
||
|
||
(defmacroS Rvector (items &rest option-plist
|
||
&key (size nil) &allow-other-keys)
|
||
"Combines the elements of ITEMS together into a vector."
|
||
(cond (size
|
||
(remf option-plist :size)
|
||
(funcallS-frag
|
||
(literal-frag
|
||
`(((items T)) ((vector)) (vector index) () ()
|
||
((setq vector (make-array ,size . ,option-plist))
|
||
(setq index 0))
|
||
((setf (aref vector index) items) (incf index)) () ()))
|
||
(list items)))
|
||
(T (setf (getf option-plist :adjustable) T)
|
||
(setf (getf option-plist :fill-pointer) 0)
|
||
(funcallS-frag
|
||
(literal-frag
|
||
`(((items T)) ((vector)) (vector) () ()
|
||
((setq vector (make-array 32 . ,option-plist)))
|
||
((vector-push-extend items vector)) () ()))
|
||
(list items)))))
|
||
|
||
(defmacroS Rhash (keys values &rest option-plist)
|
||
"Combines a series of keys and a series of values together into a hash table."
|
||
(funcallS-frag
|
||
(literal-frag
|
||
`(((keys T) (values T)) ((table)) (table) () ()
|
||
((setq table (make-hash-table . ,option-plist)))
|
||
((setf (gethash keys table) values)) () ()))
|
||
(list keys values)))
|
||
|
||
(defmacroS Rfile (name items &rest option-plist)
|
||
"Prints the elements of ITEMS into a file."
|
||
(setf (getf option-plist :direction) :output)
|
||
(funcallS-frag
|
||
(literal-frag
|
||
`(((items T)) ((out)) (out) () ()
|
||
((setq out T)) ((print items file)) ()
|
||
(#'(lambda (c)
|
||
(list 'with-open-file '(file ,name . ,option-plist) c)))))
|
||
(list items)))
|
||
|
||
(defS Ralist T
|
||
"Combines a series of keys and a series of values together into an alist."
|
||
((keys T) (values T)) ((alist)) (alist) () ()
|
||
((setq alist nil))
|
||
((setq alist (cons (cons keys values) alist)))
|
||
((setq alist (nreverse alist))) ())
|
||
|
||
(defS Rplist T
|
||
"Combines a series of indicators and a series of values together into a plist."
|
||
((indicators T) (values T)) ((plist)) (plist) () ()
|
||
((setq plist nil))
|
||
((setq plist (list* values indicators plist)))
|
||
((setq plist (nreverse plist))) ())
|
||
|
||
(defS Rfirst-late (items &optional (default nil))
|
||
"Returns the first element of ITEMS."
|
||
((items T) (default)) ((item)) (item found) () ()
|
||
((setq item default) (setq found nil))
|
||
((when (not found) (setq item items) (setq found T))) () ())
|
||
|
||
(defS Rlast (items &optional (default nil))
|
||
"Returns the last element of ITEMS."
|
||
((items T) (default)) ((item)) (item) () ()
|
||
((setq item default)) ((setq item items)) () ())
|
||
|
||
(defS Rnth-late (n items &optional (default nil))
|
||
"Returns the nth element of ITEMS."
|
||
((n) (items T) (default)) ((item)) (item counter) () ()
|
||
((setq item default) (setq counter n))
|
||
((when (zerop counter) (setq item items)) (decf counter)) () ())
|
||
|
||
(defS Rlength T "Returns the number of elements in ITEMS."
|
||
((items T)) ((number)) (number) () ()
|
||
((setq number 0)) ((incf number)) () ())
|
||
|
||
(defS Rand-late T "Computes the AND of the elements of BOOLS."
|
||
((bools T)) ((bool)) (bool) () ()
|
||
((setq bool T))
|
||
((setq bool (and bool bools))) () ())
|
||
|
||
(defS Ror-late T "Computes the OR of the elements of BOOLS."
|
||
((bools T)) ((bool)) (bool) () ()
|
||
((setq bool nil))
|
||
((setq bool (or bool bools))) () ())
|
||
|
||
(defS Rsum T "Computes the sum of the elements in NUMBERS."
|
||
((numbers T)) ((num)) (num) ((type number numbers num)) ()
|
||
((setq num 0))
|
||
((setq num (+ num numbers))) () ())
|
||
|
||
(defS Rmax T "Returns the maximum element of NUMBERS."
|
||
((numbers T)) ((number)) (number) () ()
|
||
((setq number nil))
|
||
((if (or (null number) (< number numbers)) (setq number numbers))) () ())
|
||
|
||
(defS Rmin T "Returns the minimum element of NUMBERS."
|
||
((numbers T)) ((number)) (number) () ()
|
||
((setq number nil))
|
||
((if (or (null number) (> number numbers)) (setq number numbers))) () ())
|
||
|
||
(defS ReduceF T
|
||
"Computes a cumulative value by applying FUNCTION to the elements of ITEMS."
|
||
((init) (function) (items T)) ((result)) (result) () ()
|
||
((setq result init))
|
||
((setq result (funcall function result items))) () ())
|
||
|
||
(defS Rfirst (items &optional (default nil))
|
||
"Returns the first element of ITEMS, terminating early."
|
||
((items T) (default)) ((item)) (item) () ()
|
||
((setq item default))
|
||
((setq item items) (go END)) () ())
|
||
|
||
(defS Rnth (n items &optional (default nil))
|
||
"Returns the nth element of ITEMS, terminating early."
|
||
((n) (items T) (default)) ((item)) (counter item) () ()
|
||
((setq item default) (setq counter n))
|
||
((when (zerop counter) (setq item items) (go END)) (decf counter)) () ())
|
||
|
||
(defS Rand T
|
||
"Computes the AND of the elements of BOOLS, terminating early."
|
||
((bools T)) ((bool)) (bool) () ()
|
||
((setq bool T)) ((if (null (setq bool bools)) (go END))) () ())
|
||
|
||
(defS Ror T
|
||
"Computes the OR of the elements of BOOLS, terminating early."
|
||
((bools T)) ((bool)) (bool) () ()
|
||
((setq bool nil)) ((if (setq bool bools) (go END))) () ())
|
||
|
||
;Has correct annotation, because is not a defmacroS thing.
|
||
(defmacro showS (thing &optional (format "~%~S") (stream '*standard-output*))
|
||
"Displays THING for debugging purposes."
|
||
(let ((var (gensym "SHOW-")))
|
||
`(let ((,var ,thing))
|
||
(format ,stream ,format ,var)
|
||
,var)))
|
||
|
||
;------------------------------------------------------------------------ ;
|
||
; Copyright (c) Richard C. Waters, 1988 ;
|
||
;------------------------------------------------------------------------ ;
|