(FILECREATED "22-Feb-86 21:03:20" {ERINYES}<HERRING>MISC>LISTOPCODES.;3
 5192   

      changes to:  (VARS LISTOPCODESCOMS)
                   (FNS DLISTOPCODES LOO.SORTTEST LOO.GETFIELD)

      previous date: "22-Feb-86 19:21:26" {ERINYES}<HERRING>MISC>LISTOPCODES.;1)


(* Copyright (c) 1986 by Xerox Corporation. All rights reserved.)

(PRETTYCOMPRINT LISTOPCODESCOMS)

(RPAQQ LISTOPCODESCOMS
 ((* get a cut, sorted list of OPCODE recs)
                            (FNS DLISTOPCODES)
                            (FNS LOO.GETFIELD LOO.SORTTEST)))



(* get a cut, sorted list of OPCODE recs)


(DEFINEQ

(DLISTOPCODES

  [LAMBDA (INCLTEST SORTTEST)
                                          (* jmh 
                                                                           "22-Feb-86 20:24")

            
            (* * returns a list of D-machine OPCODE records --
            as per the current DOPCODE properties of all atoms)

            
            (* * INCLTEST is either -- NIL or T = all --
            else a function to apply to an OPCODE record, returning: include this one?)

            
            (* * SORTTEST is either -- name of field of OPCODE record = sort by that 
            field major then OPCODENAME minor <LOO.SORTTEST used for the sorts> --
            NIL same as OP# -- T same as OPCODENAME --
            else a function applied to two OPCODE records returning: put first arg 
            before second?)


    (DECLARE
 (SPECVARS INCLTEST SORTTEST))
    (LET (LOO.L LOO.C)
         (DECLARE
 (SPECVARS LOO.L LOO.C))
         [MAPATOMS (FUNCTION (LAMBDA (A)
                               (LET [(OPCODEREC (GETP A (QUOTE DOPCODE]
                                    (if
 OPCODEREC
                                        then
 (push
 LOO.L OPCODEREC]
         [if
 (OR (NULL INCLTEST)
                     (EQ T INCLTEST))
             then
 (SETQ LOO.C LOO.L)
           else
 (for
 OPCODEREC in
 LOO.L DO
 (if
 (APPLY* INCLTEST OPCODEREC)
                                                               then
 (push
 LOO.C OPCODEREC]
         (SORT LOO.C (if
 (MEMB SORTTEST (QUOTE (NIL OP# T OPCODENAME OPNARGS OPPRINT LEVADJ UFNFN 
                                                        UNIMPL)))
                         then
 [FUNCTION (LAMBDA (A B)
                                              (LET ((FA (LOO.GETFIELD
 A SORTTEST))
                                                    (FB (LOO.GETFIELD
 B SORTTEST)))
                                                   (if
 (NOT (EQUAL FA FB))
                                                       then
 (LOO.SORTTEST
 FA FB)
                                                     else
 (LOO.SORTTEST
 (fetch

                                                                                 (OPCODE OPCODENAME)
                                                                                   of
 A)
                                                                     (fetch
 (OPCODE OPCODENAME)
                                                                        of
 B]
                       else
 SORTTEST])
)
(DEFINEQ

(LOO.GETFIELD

  [LAMBDA (OPCODEREC FIELD)
                                            (* jmh 
                                                                           "22-Feb-86 20:18")

    (SELECTQ FIELD
        ((OP# NIL) 
             (fetch
 (OPCODE OP#) of
 OPCODEREC))
        ((OPCODENAME T) 
             (fetch
 (OPCODE OPCODENAME) of
 OPCODEREC))
        (OPNARGS (fetch
 (OPCODE OPNARGS) of
 OPCODEREC))
        (OPPRINT (fetch
 (OPCODE OPPRINT) of
 OPCODEREC))
        (LEVADJ (fetch
 (OPCODE LEVADJ) of
 OPCODEREC))
        (UFNFN (fetch
 (OPCODE UFNFN) of
 OPCODEREC))
        (UNIMPL (fetch
 (OPCODE UNIMPL) of
 OPCODEREC))
        (HELP "loo.getfield: bad FIELD arg" FIELD])

(LOO.SORTTEST

  [LAMBDA (A B)
                                                        (* jmh 
                                                                           "22-Feb-86 20:55")

            
            (* * a function of the kind one passes to SORT --
            as ALPHORDER except -- (1) NIL before anything else
            (2) lists just after their CARs (3) lists with same CAR unsorted --
            EQUAL used for lexical equality of CARs)


    (if
 (NULL A)
        then
 T
      elseif
 (NULL B)
        then
 NIL
      elseif
 (AND (LISTP A)
                      (LISTP B))
        then
 (LOO.SORTTEST
 (CAR A)
                        (CAR B))
      elseif
 (LISTP A)
        then
 (if
 (EQUAL (CAR A)
                                B)
                     then
 NIL
                   else
 (LOO.SORTTEST
 (CAR A)
                                   B))
      elseif
 (LISTP B)
        then
 (if
 (EQUAL A (CAR B))
                     then
 T
                   else
 (LOO.SORTTEST
 A (CAR B)))
      else
 (ALPHORDER A B])
)
(PUTPROPS LISTOPCODES COPYRIGHT ("Xerox Corporation" 1986))
(DECLARE: DONTCOPY
  (FILEMAP (NIL (607 3226 (DLISTOPCODES 617 . 3224)) (3227 5110 (LOO.GETFIELD 3237 . 3982) (LOO.SORTTEST
 3984 . 5108)))))
STOP