home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / bsd_srcs / usr.bin / lisp / liszt / funb.l < prev    next >
Encoding:
Text File  |  1987-12-15  |  23.7 KB  |  788 lines
  1. (include-if (null (get 'chead 'version)) "../chead.l")
  2. (Liszt-file funb
  3.    "$Header: funb.l,v 1.13 87/12/15 17:02:17 sklower Exp $")
  4.  
  5. ;;; ----    f u n b                function compilation
  6. ;;;
  7. ;;;                -[Wed Aug 24 17:14:56 1983 by layer]-
  8.  
  9. ;--- c-declare :: handle the "declare" form
  10. ; if a declare is seen inside a function definition, we just 
  11. ; ignore it.  We probably should see what it is declareing, as it
  12. ; might be declaring a special.
  13. ;
  14. (defun c-declare nil nil)
  15.  
  16. ;--- c-do :: compile a "do" expression
  17. ;
  18. ; a do has this form:
  19. ;  (do vrbls tst . body)
  20. ; we note the special case of tst being nil, in which case the loop
  21. ; is evaluated only once, and thus acts like a let with labels allowed.
  22. ; The do statement is a cross between a prog and a lambda. It is like
  23. ; a prog in that labels are allowed. It is like a lambda in that
  24. ; we stack the values of all init forms then bind to the variables, just
  25. ; like a lambda expression (that is the initial values of even specials
  26. ; are stored on the stack, and then copied into the value cell of the
  27. ; atom during the binding phase. From then on the stack location is
  28. ; not used).
  29. ;
  30. (defun c-do nil
  31.    (let (b-vrbls b-tst b-body chklab bodylab x-repeat x-vrbs x-fst
  32.          g-loc g-cc oldreguse (g-decls g-decls))
  33.        (forcecomment '(beginning do))
  34.        (setq g-loc 'reg  chklab (d-genlab)   bodylab (d-genlab))
  35.  
  36.        (if (and (cadr v-form) (atom (cadr v-form)))
  37.        then (setq v-form (d-olddo-to-newdo (cdr v-form))))
  38.  
  39.        (push (cons 'do 0) g-locs)        ; begin our frame
  40.  
  41.        (setq b-vrbls (cadr v-form)
  42.          b-tst   (caddr v-form)
  43.          b-body  (cdddr v-form))
  44.  
  45.        (d-scanfordecls b-body)
  46.  
  47.        ; push value of init forms on stack
  48.        (d-pushargs (mapcar '(lambda (x)
  49.                 (if (atom x)
  50.                     then nil ; no init form => nil
  51.                     else (cadr x)))
  52.                b-vrbls))
  53.  
  54.        ; now bind to  the variables in the vrbls form
  55.        (d-bindlamb (mapcar '(lambda (x)
  56.                 (if (atom x) then x
  57.                     else (car x)))
  58.                b-vrbls))
  59.  
  60.        ; search through body for all labels and assign them gensymed labels
  61.        (push (cons (d-genlab)
  62.            (do ((ll b-body (cdr ll))
  63.             (res))
  64.                ((null ll) res)
  65.                (if (and (car ll) (symbolp (car ll)))
  66.                then (Push res
  67.                       (cons (car ll) (d-genlab))))))
  68.          g-labs)
  69.  
  70.        ; if the test is non nil, we do the test
  71.        ; another strange thing, a test form of (pred) will not return
  72.        ; the value of pred if it is not nil! it will return nil -- in this
  73.        ; way, it is not like a cond clause
  74.        (d-clearreg)
  75.        (if b-tst then (e-label chklab)
  76.        (let ((g-cc (cons nil bodylab)) g-loc g-ret)
  77.            (d-exp (car b-tst)))    ; eval test
  78.        ; if false, do body
  79.        (if (cdr b-tst) 
  80.            then (setq oldreguse (copy g-reguse))
  81.             (d-exps (cdr b-tst))
  82.             (setq g-reguse oldreguse)
  83.            else  (d-move 'Nil 'reg))
  84.        (e-goto (caar g-labs))        ; leave do
  85.        (e-label bodylab))        ; begin body
  86.  
  87.        ; process body
  88.        (do ((ll b-body (cdr ll))
  89.         (g-cc) (g-loc)(g-ret))
  90.        ((null ll))
  91.        (if (or (null (car ll)) (not (symbolp (car ll))))
  92.            then (d-exp (car ll))
  93.            else (e-label (cdr (assoc (car ll) (cdar g-labs))))
  94.             (d-clearreg)))
  95.  
  96.        (if b-tst
  97.        then ; determine all repeat forms which must be
  98.         ; evaluated, and all the variables affected.
  99.         ; store the results in x-repeat and  x-vrbs
  100.         ; if there is just one repeat form, we calculate
  101.         ; its value directly into where it is stored,
  102.         ; if there is more than one, we stack them
  103.         ; and then store them back at once.
  104.         (do ((ll b-vrbls (cdr ll)))
  105.             ((null ll))
  106.             (if (and (dtpr (car ll)) (cddar ll))
  107.             then (Push x-repeat (caddar ll))
  108.                  (Push x-vrbs   (caar ll))))
  109.         (if x-vrbs 
  110.             then (if (null (cdr x-vrbs))  ; if just one repeat
  111.                  then (let ((g-loc (d-locv (car x-vrbs)))
  112.                     (g-cc nil))
  113.                       (d-exp (car x-repeat)))
  114.                  else (setq x-fst (car x-repeat))
  115.                   (d-pushargs (nreverse
  116.                           (cdr x-repeat)))
  117.                   (let ((g-loc (d-locv (car x-vrbs)))
  118.                     (g-cc)
  119.                     (g-ret))
  120.                       (d-exp x-fst))
  121.                   (do ((ll (cdr x-vrbs) (cdr ll)))
  122.                       ((null ll))
  123.                       (d-move 'unstack
  124.                           (d-locv (car ll)))
  125.                       (setq g-locs (cdr g-locs))
  126.                       (decr g-loccnt))))
  127.         (e-goto chklab))
  128.  
  129.        (e-label (caar g-labs))            ; end of do label
  130.        (d-clearreg)
  131.        (d-unbind)
  132.        (setq g-labs (cdr g-labs))))
  133.  
  134. ;--- d-olddo-to-newdo  :: map old do to new do
  135. ;
  136. ; form of old do is  (do var tst . body)
  137. ; where var is a symbol, not nil
  138. ;
  139. (defun d-olddo-to-newdo (v-l)
  140.   `(do ((,(car v-l) ,(cadr v-l) ,(caddr v-l)))
  141.        (,(cadddr v-l))
  142.        ,@(cddddr v-l)))
  143.  
  144. ;--- cc-dtpr :: check for dtprness
  145. ;
  146. (defun cc-dtpr nil
  147.   (d-typesimp (cadr v-form) #.(immed-const 3)))
  148.  
  149. ;--- cc-eq :: compile an "eq" expression
  150. ;
  151. (defun cc-eq nil
  152.    (let ((arg1 (cadr v-form))
  153.      (arg2 (caddr v-form))
  154.      arg1loc
  155.      arg2loc)
  156.        (if (setq arg2loc (d-simple arg2))
  157.        then (if (setq arg1loc (d-simple arg1))
  158.             then ; eq <simple> <simple>
  159.              (d-cmp arg1loc arg2loc)
  160.             else ; eq <nonsimple> <simple>
  161.              (let ((g-loc 'reg)    ; put <nonsimple> in reg
  162.                    ; must rebind because
  163.                    ; cc->& may have modified
  164.                    (g-trueop #+(or for-vax for-tahoe) 'jneq
  165.                      #+for-68k 'jne)
  166.                    (g-falseop #+(or for-vax for-tahoe) 'jeql
  167.                       #+for-68k 'jeq)
  168.                    g-cc
  169.                    g-ret)
  170.                  (d-exp arg1))
  171.              (d-cmp 'reg arg2loc))
  172.        else ; since second is nonsimple, must stack first
  173.         ; arg out of harms way
  174.         (let ((g-loc 'stack)
  175.               (g-trueop #+(or for-vax for-tahoe) 'jneq #+for-68k 'jne)
  176.               (g-falseop #+(or for-vax for-tahoe) 'jeql #+for-68k 'jeq)
  177.               g-cc
  178.               g-ret)
  179.             (d-exp arg1)
  180.             (push nil g-locs)
  181.             (incr g-loccnt)
  182.             (setq g-loc 'reg)        ; second arg to reg
  183.             (d-exp arg2))
  184.         (d-cmp 'unstack 'reg)
  185.         (setq g-locs (cdr g-locs))
  186.         (decr g-loccnt)))
  187.    (d-invert))
  188.  
  189. ;--- cc-equal :: compile `equal'
  190. ;
  191. (defun cc-equal nil
  192.   (let ((lab1 (d-genlab))
  193.     (lab11 (d-genlab))
  194.     lab2)
  195.        (d-pushargs (cdr v-form))
  196.        (e-cmp '(-8 #.np-reg) '(-4 #.np-reg))
  197.        (e-gotonil lab1)
  198.        (d-calltran 'equal '2)         ; not eq, try equal.
  199.        (d-clearreg)
  200.        #+(or for-vax for-tahoe) (e-tst (e-cvt 'reg))
  201.        #+for-68k (e-cmpnil (e-cvt 'reg))
  202.        (e-gotot lab11)        
  203.        (if g-loc then (d-move 'Nil g-loc))
  204.        (if (cdr g-cc) then (e-goto (cdr g-cc))
  205.        else (e-goto (setq lab2 (d-genlab))))
  206.        (e-writel lab1)
  207.        (e-dropnp 2)
  208.        (e-writel lab11)
  209.        (if g-loc then (d-move 'T g-loc))
  210.        (if (car g-cc) then (e-goto (car g-cc)))
  211.        (if lab2 then (e-writel lab2))
  212.        (setq g-locs (cddr g-locs))
  213.        (setq g-loccnt (- g-loccnt 2))))
  214.  
  215. ;--- c-errset :: compile an errset expression
  216. ;
  217. ; the errset has this form: (errset 'value ['tag])
  218. ; where tag defaults to t.
  219. ;
  220. (defun c-errset nil
  221.   (let ((g-loc 'reg)
  222.     (g-cc nil)
  223.     (g-ret nil)
  224.     (finlab (d-genlab))
  225.     (beglab (d-genlab)))
  226.        (d-exp (if (cddr v-form) then (caddr v-form) else t))
  227.        (d-pushframe #.F_CATCH (d-loclit 'ER%all nil) 'reg)
  228.        (push nil g-labs)        ; disallow labels
  229.        ; If retval is non zero then an error has throw us here so we 
  230.        ; must recover the value thrown (from _lispretval) and leave
  231.        ; If retval is zero then we shoud calculate the expression 
  232.        ; into r0  and put a cons cell around it
  233.        (e-tst '_retval)
  234.        (e-write2 #+(or for-vax for-tahoe) 'jeql #+for-68k 'jeq beglab)
  235.        (e-move '_lispretval (e-cvt 'reg))
  236.        (e-write2 #+(or for-vax for-tahoe) 'jbr #+for-68k 'jra finlab)
  237.        (e-label beglab)
  238.        (let ((g-loc 'stack)
  239.          (g-cc nil))
  240.         (d-exp (cadr v-form)))
  241.        (d-move 'Nil 'stack)    ; haven't updated g-loc, g-loccnt but it
  242.                 ; shouldn't hurt (famous last words)
  243.        (e-quick-call '_qcons)
  244.        (e-label finlab)
  245.        (d-popframe)
  246.        (unpush g-locs)        ; remove (catcherrset . 0)
  247.        (unpush g-labs)        ; remove nil
  248.        (d-clearreg)))
  249.  
  250. ;--- cm-fixnum-cxr :: open code a fixnum-cxr expression.
  251. ; 
  252. ; fixnum-cxr is a compile only hacky function which accesses an element
  253. ; of a fixnum space and boxes the resulting fixnum.  It can be used
  254. ; for rapid access to user defined structures.
  255. ;
  256. (defun cm-fixnum-cxr ()
  257.   `(internal-fixnum-box (cxr ,@(cdr v-form))))
  258.  
  259. (defun c-internal-fixnum-box ()
  260.   (let ((g-cc nil)
  261.     (g-ret nil)
  262.     (g-loc '#.fixnum-reg))
  263.        #+for-68k (d-regused '#.fixnum-reg)
  264.        (d-exp (cadr v-form))
  265.        (e-call-qnewint)))
  266.  
  267. ;--- cc-offset-cxr
  268. ; return a pointer to the address of the object instead of the object.
  269. ;
  270. (defun cc-offset-cxr nil
  271.   (d-supercxr nil t))
  272.  
  273. ;--- cc-fixp :: check for a fixnum or bignum
  274. ;
  275. (defun cc-fixp nil
  276.   (d-typecmplx (cadr v-form) 
  277.            '#.(immed-const (plus 1_2 1_9))))
  278.  
  279. ;--- cc-floatp :: check for a flonum
  280. ;
  281. (defun cc-floatp nil
  282.   (d-typesimp (cadr v-form) #.(immed-const 4)))
  283.  
  284. ;--- c-funcall :: compile a funcall
  285. ;
  286. ; we open code a funcall the resulting object is a compiled lambda.
  287. ; We don't open code nlambda and macro funcalls since they are
  288. ; rarely used and it would waste space to check for them
  289. (defun c-funcall nil
  290.    (if (null (cdr v-form))
  291.       then (comp-err "funcall requires at least one argument " v-form))
  292.    (let ((g-locs g-locs)
  293.      (g-loccnt g-loccnt)
  294.      (args (length (cdr v-form)))
  295.      (g-loc nil)
  296.      (g-ret nil)
  297.      (g-cc nil))
  298.       (d-pushargs (cdr v-form))
  299.       (rplaca (nthcdr (1- args) g-locs) 'funcallfcn)
  300.  
  301.       (d-exp '(cond ((and (symbolp funcallfcn)
  302.               (getd funcallfcn))
  303.              (setq funcallfcn (getd funcallfcn)))))
  304.          
  305.       (d-exp `(cond ((and (bcdp funcallfcn) (eq 'lambda (getdisc funcallfcn)))
  306.             (Internal-bcdcall ,args t))
  307.                (t (Internal-bcdcall  ,args nil))))))
  308.  
  309. ;--- c-Internal-bcdcall
  310. ; this is a compiler internal function call.  when this occurs, there
  311. ;  are argnum objects stacked, the first of which is a function name
  312. ;  or bcd object.  If dobcdcall is t then we want to do a bcdcall of
  313. ;  the first object stacked.  If it is not true then we want to
  314. ;  call the interpreter funcall function to handle it.
  315. ;
  316. (defun c-Internal-bcdcall nil
  317.    (let ((argnum (cadr v-form))
  318.      (dobcdcall (caddr v-form)))
  319.       (cond (dobcdcall (d-bcdcall argnum))
  320.         (t (d-calltran 'funcall argnum)))))
  321.  
  322. ;--- cc-function :: compile a function function
  323. ;
  324. ; function is an nlambda, which the interpreter treats as 'quote'
  325. ; If the argument is a lambda expression, then Liszt will generate
  326. ; a new function and generate code to return the name of
  327. ; that function.  If the argument is a symbol, then 'symbol
  328. ; is compiled.   It would probably be better to return the function
  329. ; cell of the symbol, but Maclisp returns the symbol and it
  330. ; would cause compatibility problems.
  331. ;
  332. (defun cc-function nil
  333.    (if (or (null (cdr v-form))
  334.        (cddr v-form))
  335.       then (comp-err "Wrong number of arguments to 'function': " v-form))
  336.    (let ((arg (cadr v-form)))
  337.       (if (symbolp arg)
  338.      then (d-exp `',arg)
  339.        elseif (and (dtpr arg)
  340.            (memq (car arg) '(lambda nlambda lexpr)))
  341.      then (let ((newname (concat "in-line-lambda:"
  342.                      (setq in-line-lambda-number
  343.                        (add1 in-line-lambda-number)))))
  344.          (Push liszt-process-forms
  345.                `(def ,newname ,arg))
  346.          (d-exp `',newname))
  347.      else (comp-err "Illegal argument to 'function': " v-form))))
  348.  
  349. ;--- c-get :: do a get from the prop list
  350. ;
  351. (defun c-get nil
  352.   (if (not (eq 2 (length (cdr v-form))))
  353.       then (comp-err "Wrong number of args to get " v-form))
  354.   (d-pushargs (cdr v-form))        ; there better be 2 args
  355.   (e-quick-call '_qget)
  356.   (d-clearreg)
  357.   (setq g-locs (cddr g-locs))
  358.   (setq g-loccnt (- g-loccnt 2)))
  359.  
  360. ;--- cm-getaccess :: compile a getaccess instruction
  361. ;
  362. (defun cm-getaccess nil `(cdr ,(cadr v-form)))
  363.  
  364. ;--- cm-getaux :: compile a getaux instruction
  365. ;
  366. (defun cm-getaux  nil `(car ,(cadr v-form)))
  367.  
  368. ;--- cm-getd :: compile a getd instruction
  369. ;
  370. ; the getd function is open coded to look in the third part of a symbol
  371. ; cell
  372. ;
  373. (defun cm-getd nil `(cxr 2 ,(cadr v-form)))
  374.  
  375. ;--- cm-getdata :: compile a getdata instruction
  376. ;
  377. ; the getdata function is open coded to look in the third part of an 
  378. ; array header.
  379. (defun cm-getdata nil `(cxr 2 ,(cadr v-form)))
  380.  
  381. ;--- cm-getdisc  :: compile a getdisc expression
  382. ; getdisc accessed the discipline field of a binary object.
  383. ;
  384. (defun cm-getdisc nil `(cxr 1 ,(cadr v-form)))
  385.  
  386. ;--- c-go :: compile a "go" expression
  387. ;
  388. ; we only compile the (go symbol)type expression, we do not
  389. ; allow symbol to be anything by a non null symbol.
  390. ;
  391. (defun c-go nil
  392.    ; find number of frames we have to go down to get to the label
  393.    (do ((labs g-labs (cdr labs))
  394.     (locs g-locs)
  395.     (locals 0)
  396.     (specials 0)
  397.     (catcherrset 0)
  398.     (label))
  399.        ((null labs)
  400.     (comp-err "go label not found for expression: " (or v-form)))
  401.  
  402.        (if (car labs)         ; if we have a set of labels to look at...
  403.        then (if (setq label
  404.               (do ((lbs (cdar labs) (cdr lbs)))
  405.                   ((null lbs))
  406.                   (if (eq (caar lbs) (cadr v-form))
  407.                   then (return (cdar lbs)))))
  408.             then (if (not (eq labs g-labs))
  409.                  then (comp-note g-fname ": non local go used : "
  410.                          (or v-form)))
  411.              ; three stack to pop: namestack, bindstack
  412.              ;   and execution stack
  413.              (e-pop locals)
  414.              (if (greaterp specials 0)
  415.                  then (e-unshallowbind specials))
  416.              (if (greaterp catcherrset 0)
  417.                  then (comp-note g-fname
  418.                          ": Go through a catch or errset "
  419.                          v-form)
  420.                   (do ((i 0 (1+ i)))
  421.                       ((=& catcherrset i))
  422.                       (d-popframe)))
  423.              (e-goto label)
  424.              (return)))
  425.        ; tally all locals, specials and catcherrsets used in this frame
  426.        (do ()
  427.        ((dtpr (car locs))
  428.         (if (eq 'catcherrset (caar locs))
  429.            then (incr catcherrset)
  430.          elseif (eq 'progv (caar locs))
  431.            then (comp-err "Attempt to 'go' through a progv"))
  432.         (setq specials (+ specials (cdar locs))
  433.           locs (cdr locs)))
  434.        (setq locs (cdr locs))
  435.        (incr locals))))
  436.             
  437. ;--- cc-ignore :: just ignore this code
  438. ;
  439. (defun cc-ignore nil
  440.   nil)
  441.  
  442. ;--- c-lambexp :: compile a lambda expression
  443. ;
  444. (defun c-lambexp nil
  445.   (let ((g-loc (if (or g-loc g-cc) then 'reg))
  446.     (g-cc nil)
  447.     (g-locs (cons (cons 'lambda 0) g-locs))
  448.     (g-labs (cons nil g-labs)))
  449.        (d-pushargs (cdr v-form))        ; then push vals
  450.        (d-lambbody (car v-form))
  451.        (d-clearreg)))
  452.  
  453. ;--- d-lambbody :: do a lambda body
  454. ;    - body : body of lambda expression, eg (lambda () dld)
  455. ;
  456. (defun d-lambbody (body)
  457.    (let ((g-decls g-decls))
  458.       (d-scanfordecls (cddr body))        ; look for declarations
  459.       (d-bindlamb (cadr body))        ; bind locals
  460.       (d-clearreg)
  461.       (d-exp (do ((ll (cddr body) (cdr ll))
  462.           (g-loc)
  463.           (g-cc)
  464.           (g-ret))
  465.          ((null (cdr ll)) (car ll))
  466.          (d-exp (car ll))))
  467.  
  468.       (d-unbind)))                ; unbind this frame
  469.  
  470. ;--- d-bindlamb :: bind  variables in lambda list
  471. ;    - vrbs : list of lambda variables, may include nil meaning ignore
  472. ;
  473. (defun d-bindlamb (vrbs)
  474.   (let ((res (d-bindlrec (reverse vrbs) g-locs 0 g-loccnt)))
  475.        (if res then (e-setupbind)
  476.             (mapc '(lambda (vrb) (e-shallowbind (car vrb) (cdr vrb)))
  477.               res)
  478.             (e-unsetupbind))))
  479.   
  480. ;--- d-bindlrec :: recusive routine to bind lambda variables
  481. ;    - vrb : list of variables yet to bind
  482. ;    - locs : current location in g-loc
  483. ;    - specs : number of specials seen so far
  484. ;    - lev  : how far up from the bottom of stack we are.
  485. ; returns: list of elements, one for each special, of this form:
  486. ;        (<specialvrbname> stack <n>)
  487. ;    where specialvrbname is the name of the special variable, and n is
  488. ;    the distance from the top of the stack where its initial value is 
  489. ;    located
  490. ; also: puts the names of the local variables in the g-locs list, as well
  491. ;    as placing the number of special variables in the lambda header.
  492. ;
  493. (defun d-bindlrec (vrb locs specs lev)
  494.    (if vrb 
  495.        then (let ((spcflg (d-specialp (car vrb)))
  496.           retv)
  497.         (if spcflg then (setq specs (1+ specs)))
  498.  
  499.         (if (cdr vrb)        ; if more vrbls to go ...
  500.             then (setq retv (d-bindlrec (cdr vrb)
  501.                         (cdr locs)
  502.                         specs
  503.                         (1- lev)))
  504.             else (rplacd (cadr locs)
  505.                  specs))    ; else fix up lambda hdr
  506.  
  507.         (if (not spcflg) then (rplaca locs (car vrb))
  508.             else (Push retv `(,(car vrb) stack ,lev)))
  509.  
  510.         retv)))
  511.  
  512. ;--- d-scanfordecls
  513. ; forms - the body of a lambda, prog or do.
  514. ;  we look down the form for 'declare' forms.  They should be at the
  515. ;  beginning, but there are macros which may unintentionally put forms
  516. ;  in front of user written forms.  Thus we check a little further than
  517. ;  the first form.
  518. (defun d-scanfordecls (forms)
  519.    ; look for declarations in the first few forms
  520.    (do ((count 3 (1- count)))
  521.        ((= 0 count))
  522.        (cond ((and (dtpr (car forms))
  523.            (eq 'declare (caar forms))
  524.            (apply 'liszt-declare (cdar forms)))))
  525.        (setq forms (cdr forms))))
  526.  
  527. ;--- c-list :: compile a list expression
  528. ;
  529. ; this is compiled as a bunch of conses with a nil pushed on the
  530. ; top for good measure
  531. ;
  532. (defun c-list nil
  533.   (prog (nargs)
  534.     (setq nargs (length (cdr v-form)))
  535.     (makecomment '(list expression))
  536.     (if (zerop nargs)
  537.         then (d-move 'Nil 'reg)    ; (list) ==> nil
  538.          (return))
  539.     (d-pushargs (cdr v-form))
  540.     #+(or for-vax for-tahoe) (e-write2 'clrl '#.np-plus) ; stack one nil
  541.     #+for-68k (L-push (e-cvt 'Nil))
  542.  
  543.        ; now do the consing
  544.        (do ((i (max 1 nargs) (1- i)))
  545.        ((zerop i))
  546.        (e-quick-call '_qcons)
  547.        (d-clearreg)
  548.        (if (> i 1) then (L-push (e-cvt 'reg))))
  549.  
  550.        (setq g-locs (nthcdr nargs g-locs)
  551.          g-loccnt (- g-loccnt nargs))))
  552.  
  553. ;--- d-mapconvert - access : function to access parts of lists
  554. ;          - join     : function to join results
  555. ;          - resu     : function to apply to result
  556. ;          - form     : mapping form
  557. ;    This function converts maps to an equivalent do form.
  558. ;
  559. ;  in this function, the variable vrbls contains a list of forms, one form
  560. ;  per list we are mapping over.  The form of the form is 
  561. ;    (dummyvariable  realarg  (cdr dummyvariable))
  562. ; realarg may be surrounded by (setq <variable which holds result> realarg)
  563. ; in the case that the result is the list to be mapped over (this only occurs
  564. ; with the function mapc).
  565. ;
  566. (defun d-mapconvert (access join resu form )
  567.    (prog (vrbls finvar acc accform compform
  568.         tmp testform tempvar lastvar)
  569.  
  570.        (setq finvar (gensym 'X)   ; holds result
  571.  
  572.          vrbls
  573.          (reverse
  574.          (maplist '(lambda (arg)
  575.                    ((lambda (temp)
  576.                     (cond ((or resu (cdr arg))
  577.                        `(,temp ,(car arg)
  578.                           (cdr ,temp)))
  579.                       (t `(,temp
  580.                         (setq ,finvar
  581.                                ,(car arg))
  582.                         (cdr ,temp)))))
  583.                 (gensym 'X)))
  584.               (reverse (cdr form))))
  585.  
  586.          ; the access form will either be nil or car.  If it is
  587.          ; nil, then we are doing something like a maplist,
  588.          ; if the access form is car, then we are doing something
  589.          ; like a mapcar.
  590.          acc (mapcar '(lambda (tem)
  591.                   (cond (access `(,access ,(car tem)))
  592.                     (t (car tem))))
  593.              vrbls)
  594.  
  595.          accform (cond ((or (atom (setq tmp (car form)))
  596.                 (null (setq tmp (d-macroexpand tmp)))
  597.                 (not (member (car tmp) '(quote function))))
  598.                 `(funcall ,tmp ,@acc))
  599.                (t `(,(cadr tmp) ,@acc)))
  600.  
  601.          ; the testform checks if any of the lists we are mapping
  602.          ; over is nil, in which case we quit.
  603.          testform (cond ((null (cdr vrbls)) `(null ,(caar vrbls)))
  604.                 (t `(or ,@(mapcar '(lambda (x)
  605.                            `(null ,(car  x)))
  606.                           vrbls)))))
  607.  
  608.        ; in the case of mapcans and mapcons, you need two
  609.        ; extra variables to simulate the nconc.
  610.        ; testvar gets intermediate results and lastvar
  611.        ; points to then end of the list
  612.        (if (eq join 'nconc)
  613.        then (setq tempvar (gensym 'X)
  614.               lastvar (gensym 'X)
  615.               vrbls `((,tempvar) (,lastvar) ,@vrbls)))
  616.  
  617.        (return
  618.        `((lambda
  619.          (,finvar)
  620.          (liszt-internal-do
  621.              ( ,@vrbls)
  622.              (,testform)
  623.              ,(cond ((eq join 'nconc)
  624.                  `(cond ((setq ,tempvar ,accform)
  625.                      (cond (,lastvar
  626.                          (liszt-internal-do
  627.                          ()
  628.                          ((null (cdr ,lastvar)))
  629.                          (setq ,lastvar
  630.                                (cdr ,lastvar)))
  631.                          (rplacd ,lastvar ,tempvar))
  632.                        (t (setq ,finvar
  633.                              (setq ,lastvar
  634.                                ,tempvar)))))))
  635.                 (join `(setq ,finvar (,join ,accform ,finvar)))
  636.                 (t accform)))
  637.          ,(cond ((eq resu 'identity) finvar)
  638.             (resu `(,resu ,finvar))
  639.             (t finvar)))
  640.          nil ))))
  641.  
  642. ; apply to successive elements, return second arg
  643. (defun cm-mapc nil
  644.       (d-mapconvert 'car nil nil (cdr v-form)))
  645.  
  646. ; apply to successive elements, return list of results
  647. (defun cm-mapcar nil
  648.       (d-mapconvert 'car 'cons 'nreverse (cdr v-form)))
  649.  
  650. ; apply to successive elements, returned nconc of results
  651. (defun cm-mapcan nil
  652.       (d-mapconvert 'car 'nconc 'identity (cdr v-form)))
  653.  
  654. ; apply to successive sublists, return second arg
  655. (defun cm-map nil
  656.       (d-mapconvert nil nil nil (cdr v-form)))
  657.  
  658. ; apply to successive sublists, return list of results
  659. (defun cm-maplist nil
  660.       (d-mapconvert nil 'cons 'reverse (cdr v-form)))
  661.  
  662. ; apply to successive sublists, return nconc of results
  663. (defun cm-mapcon nil
  664.       (d-mapconvert nil 'nconc 'identity (cdr v-form)))
  665.  
  666. ;--- cc-memq :: compile a memq expression
  667. ;
  668. #+(or for-vax for-tahoe)
  669. (defun cc-memq nil
  670.   (let ((loc1 (d-simple (cadr v-form)))
  671.     (loc2 (d-simple (caddr v-form)))
  672.     looploc finlab)
  673.        (if loc2
  674.        then (d-clearreg 'r1)
  675.         (if loc1
  676.             then (d-move loc1 'r1)
  677.             else (let ((g-loc 'r1)
  678.                    g-cc
  679.                    g-ret)
  680.                  (d-exp (cadr v-form))))
  681.         (d-move loc2 'reg)
  682.        else (let ((g-loc 'stack)
  683.               g-cc
  684.               g-ret)
  685.             (d-exp (cadr v-form)))
  686.         (push nil g-locs)
  687.         (incr g-loccnt)
  688.         (let ((g-loc 'reg)
  689.               g-cc
  690.               g-ret)
  691.             (d-exp (caddr v-form)))
  692.         (L-pop 'r1)
  693.         (d-clearreg 'r1)
  694.         (unpush g-locs)
  695.         (decr g-loccnt))
  696.        ; now set up the jump addresses
  697.        (if (null g-loc)
  698.        then (setq loc1 (if (car g-cc) thenret else (d-genlab))
  699.               loc2 (if (cdr g-cc) thenret else (d-genlab)))
  700.        else (setq loc1 (d-genlab)
  701.               loc2 (d-genlab)))
  702.  
  703.        (setq looploc (d-genlab))
  704.        (e-tst 'r0)
  705.        (e-write2 'jeql loc2)
  706.        (e-label looploc)
  707.        (e-cmp 'r1 '(4 r0))
  708.        (e-write2 'jeql loc1)
  709.        (e-move '(0 r0) 'r0)
  710.        (e-write2 'jneq looploc)
  711.        (if g-loc
  712.        then (e-label loc2)        ; nil result
  713.         (d-move 'reg g-loc)
  714.         (if (cdr g-cc)
  715.             then (e-goto (cdr g-cc))
  716.             else (e-goto (setq finlab (d-genlab))))
  717.        else (if (cdr g-cc)
  718.             then (e-goto (cdr g-cc))
  719.             else (e-label loc2)))
  720.        (if g-loc
  721.        then (e-label loc1)        ; non nil result
  722.         (d-move 'reg g-loc)
  723.         (if (car g-cc) then (e-goto (car g-cc)))
  724.        else (if (null (car g-cc)) then (e-label loc1)))
  725.        (if finlab then (e-label finlab))))
  726.  
  727. #+for-68k
  728. (defun cc-memq nil
  729.    (let ((loc1 (d-simple (cadr v-form)))
  730.      (loc2 (d-simple (caddr v-form)))
  731.      looploc finlab
  732.      (tmp-data-reg (d-alloc-register 'd nil)))
  733.        (d-clearreg tmp-data-reg)
  734.        (d-clearreg 'a0)
  735.        (if loc2
  736.        then (if loc1
  737.             then (d-move loc1 tmp-data-reg)
  738.             else (let ((g-loc tmp-data-reg)
  739.                    g-cc
  740.                    g-ret)
  741.                  (d-exp (cadr v-form))))
  742.         (d-move loc2 'reg)
  743.        else (let ((g-loc 'stack)
  744.               g-cc
  745.               g-ret)
  746.             (d-exp (cadr v-form)))
  747.         (push nil g-locs)
  748.         (incr g-loccnt)
  749.         (let ((g-loc 'reg)
  750.               g-cc
  751.               g-ret)
  752.             (d-exp (caddr v-form)))
  753.         (L-pop tmp-data-reg)
  754.         (unpush g-locs)
  755.         (decr g-loccnt))
  756.        ; now set up the jump addresses
  757.        (if (null g-loc)
  758.        then (setq loc1 (if (car g-cc) thenret else (d-genlab))
  759.               loc2 (if (cdr g-cc) thenret else (d-genlab)))
  760.        else (setq loc1 (d-genlab)
  761.               loc2 (d-genlab)))
  762.        (setq looploc (d-genlab))
  763.        (e-cmpnil 'd0)
  764.        (e-write2 'jeq loc2)
  765.        (e-move 'd0 'a0)
  766.        (e-label looploc)
  767.        (e-cmp tmp-data-reg '(4 a0))
  768.        (e-write2 'jeq loc1)
  769.        (e-move '(0 a0) 'a0)
  770.        (e-cmpnil 'a0)
  771.        (e-write2 'jne looploc)
  772.        (e-move 'a0 'd0)
  773.        (if g-loc
  774.        then (e-label loc2)            ; nil result
  775.         (d-move 'reg g-loc)
  776.         (if (cdr g-cc)
  777.             then (e-goto (cdr g-cc))
  778.             else (e-goto (setq finlab (d-genlab))))
  779.        else (if (cdr g-cc)
  780.             then (e-goto (cdr g-cc))
  781.             else (e-label loc2)))
  782.        (if g-loc
  783.        then (e-label loc1)            ; non nil result
  784.         (d-move 'a0 g-loc)        ;a0 was cdr of non-nil result
  785.         (if (car g-cc) then (e-goto (car g-cc)))
  786.        else (if (null (car g-cc)) then (e-label loc1)))
  787.        (if finlab then (e-label finlab))))
  788.