<mdl.comp>/mapps1.mud.207

   1 <PACKAGE "MAPPS1">
   2
   3 <ENTRY PMAPF-R>
   4
   5 <USE "PASS1" "CHKDCL" "COMPDEC" "ADVMESS">
   6
   7 <DEFINE PMAPF-R (OB AP
   8                  "AUX" (NAME <1 .OB>) TT ITRF OBJ (RQRG 0)
   9                        (LN <LENGTH <SET OBJ <REST .OB>>>) FINALF TAPL (APL ())
  10                        (DCL #DECL ()) (ARGL ()) (HATOM <>) (NN 0) TEM L2 L3
  11                        (TRG 0))
  12    #DECL ((OBJ OB) <PRIMTYPE LIST> (LN NN) FIX
  13           (DCL) DECL (ARGL APL) LIST (ITRF FINALF TT) NODE
  14           (TRG RQRG) <SPECIAL FIX>)
  15    <PROG ()
  16      <AND <SEG? <REST .OBJ>>
  17           <COND (.VERBOSE
  18                  <VMESS "MAPF/MAPR cannot be open compiled due to SEGMENT."
  19                         .OB> T)(ELSE T)>
  20           <RETURN <PSUBR-C .OB .AP>>>
  21      <AND <L? .LN 2>
  22          <MESSAGE ERROR "TOO FEW ARGS TO " .NAME .OBJ>>
  23      <SET TT <NODEFM ,MAP-CODE .PARENT <> .NAME () .AP>>
  24      <SET FINALF <PCOMP <1 .OBJ> .TT>>
  25      <COND
  26       (<OR <TYPE? <SET TAPL <2 .OBJ>> FUNCTION>
  27            <AND <TYPE? .TAPL FORM>
  28                 <NOT <EMPTY? <SET APL <CHTYPE .TAPL LIST>>>>
  29                 <TYPE? <SET TEM <1 .APL>> ATOM>
  30                 <GASSIGNED? .TEM>
  31                 <==? ,.TEM ,FUNCTION>
  32                 <SET TAPL <REST .APL>>>>
  33        <AND <EMPTY? <SET APL <CHTYPE .TAPL LIST>>>
  34            <MESSAGE ERROR "EMPTY FUNCTION IN MAPF " .OBJ>>
  35        <AND <TYPE? <1 .APL> ATOM>
  36            <SET HATOM <1 .APL>>
  37            <SET APL <REST .APL>>>
  38        <AND <EMPTY? .APL>
  39            <MESSAGE ERROR "MAPF FUNCTION HAS NO ARG LIST " .OBJ>>
  40        <SET ARGL <1 .APL>>
  41        <REPEAT ((I <+ <LENGTH <REST .OBJ 2>> 1>))
  42                <COND (<L? <SET I <- .I 1>> 0> <RETURN>)>
  43                <SET ARGL (DUMMY-MAPF !.ARGL)>>
  44        <SET APL <REST .APL>>
  45        <AND <NOT <EMPTY? .APL>>
  46             <TYPE? <1 .APL> DECL>
  47             <SET DCL <1 .APL>>
  48             <SET APL <REST .APL>>>
  49        <AND <EMPTY? .APL>
  50            <MESSAGE ERROR "MAPF FUNCTION HAS NO BODY " .OBJ>>
  51        <PROG ((VARTBL .VARTBL)) #DECL ((VARTBL) <SPECIAL SYMTAB>)
  52         <SET ITRF
  53             <NODEPR ,MFCN-CODE
  54                     .TT
  55                     <OR <FIND:DECL VALUE .DCL> ANY>
  56                     <>
  57                     ()
  58                     <>
  59                     <2 <GEN-D .ARGL .DCL .HATOM <>>>
  60                     .HATOM
  61                     .VARTBL>>
  62        <COND
  63         (<ACT-FIX .ITRF <BINDING-STRUCTURE .ITRF>>
  64          <SET L3 <SET L2 ()>>
  65          <PUT
  66           .ITRF
  67           ,BINDING-STRUCTURE
  68           <REPEAT ((L <BINDING-STRUCTURE .ITRF>) (LL .L) (L1 .L) SYM)
  69                   #DECL ((L L1 LL) <LIST [REST SYMTAB]>)
  70                   <AND <EMPTY? .L> <RETURN .L1>>
  71                   <COND (<==? <CODE-SYM <SET SYM <1 .L>>> 1>
  72                          <SET L2 ("ACT" <NAME-SYM .SYM> !.L2)>
  73                          <SET L3
  74                               ((<NAME-SYM .SYM>)
  75                                <COND (<SPEC-SYM .SYM>
  76                                       <FORM SPECIAL <1 <DECL-SYM .SYM>>>)
  77                                      (ELSE
  78                                       <FORM UNSPECIAL <1 <DECL-SYM .SYM>>>)>
  79                                !.L3)>
  80                          <COND (<==? .L .L1> <SET L1 <REST .L1>>)
  81                                (ELSE <PUTREST .LL <REST .L>>)>)>
  82                   <SET L <REST <SET LL .L>>>>>
  83          <SET APL (<FORM PROG .L2 <CHTYPE .L3 DECL> !.APL>)>)>
  84        <PUT .ITRF
  85             ,KIDS
  86             <MAPF ,LIST <FUNCTION (O) <PCOMP .O .ITRF>> .APL>>>)
  87       (<OR <AND <TYPE? .TAPL FIX> <==? .LN 3>>
  88            <AND <TYPE? .TAPL FORM>
  89                 <==? <LENGTH <SET APL <CHTYPE .TAPL LIST>>> 2>
  90                 <TYPE? <SET TEM <1 .APL>> ATOM>
  91                 <==? ,.TEM ,GVAL>
  92                 <TYPE? <SET TEM <2 .APL>> ATOM>
  93                 <GASSIGNED? .TEM>
  94                 <OR <NOT <TYPE? ,.TEM FUNCTION>>
  95                     <==? .TEM .FCNS>
  96                     <AND <TYPE? .FCNS LIST> <MEMQ .TEM .FCNS>>>>>
  97        <PUT .IND PTHIS-OBJECT ,PMARGS>
  98        <SET ITRF
  99             <COND (<TYPE? .TAPL FIX> <PCOMP <FORM NTH .IND .TAPL> .TT>)
 100                   (ELSE
 101                    <PCOMP <FORM <2 .APL> !<ILIST <- .LN 2> '.IND>> .TT>)>>
 102        <PUT .IND PTHIS-OBJECT>
 103        <MAPF <>
 104              <FUNCTION (N)
 105                      #DECL ((N) NODE)
 106                      <AND <==? <NODE-TYPE .N> ,MARGS-CODE>
 107                           <PUT .N ,NODE-NAME <SET NN <+ .NN 1>>>>>
 108              <KIDS .ITRF>>
 109        <SET ITRF <NODEFM ,MPSBR-CODE .TT <> <> (.ITRF) <>>>)
 110       (ELSE <SET ITRF <PCOMP .TAPL .TT>>)>
 111      <PUT .TT
 112           ,KIDS
 113           (.FINALF
 114            .ITRF
 115            !<MAPF ,LIST <FUNCTION (O) <PCOMP .O .TT>> <REST .OBJ 2>>)>
 116      .TT>>
 117
 118 \\f
 119
 120 <DEFINE PMARGS (O) #DECL ((VALUE) NODE) <NODEFM ,MARGS-CODE .PARENT <> <> () <>>>
 121
 122 <PUT ,MAPF PAPPLY-OBJECT ,PMAPF-R>
 123
 124 <PUT ,MAPR PAPPLY-OBJECT ,PMAPF-R>
 125
 126 <ENDPACKAGE>