home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / snobol / aisnobol / snolib.inc < prev    next >
Text File  |  1987-10-12  |  45KB  |  1,537 lines
  1. * SNOLIB.INC - SNOBOL4+ VERSION
  2. *
  3. * An auxiliary file, SNOLIB.IDX, maintains a table of pointers to
  4. * the functions in this file.
  5. *
  6. * AFTER MAKING ANY ALTERATION TO THIS FILE, BE SURE TO RUN THE BUILDLIB
  7. * PROGRAM TO CREATE A CURRENT VERSION OF SNOLIB.IDX.
  8. *
  9.  DEFINE('ABS(X)')     :(ABS.END)
  10. ABS
  11.        NUMARG( .ABS, 1,   .X)
  12.        ABS = GE(X,0) X    :S(RETURN)
  13.        ABS = -X      :(RETURN)
  14. ABS.END
  15. *
  16.  DEFINE('ACOS(X)K,TERM,T')     :(ACOS.END)
  17. ACOS
  18.        NUMARG( .ACOS, 1,  .X)
  19.        (LT(X,-1) TDUMP( .ACOS,  1))
  20.        (GT(X,1) TDUMP( .ACOS,  1))
  21.        ACOS = LT(X,0) P...I. - ACOS( -X)  :S(RETURN)
  22.        ACOS = 1.0
  23.        TERM = 1.0
  24.        X = DFLOAT(1 - X)
  25.        K = 1
  26. ACOS1
  27. +      TERM = (TERM *  (2 * K - 1) * X) /
  28. +               (4 * K)
  29.        ACOS = ACOS + TERM / (2 *  K + 1)
  30.        K = K + 1
  31.        T = NE(ACOS,T) ACOS     :S(ACOS1)
  32.        ACOS = SQRT(2 * X) * ACOS    :(RETURN)
  33. ACOS.END
  34. *
  35.  DEFINE('ADD(X,Y)')      :(ADD.END)
  36. ADD
  37.        ADD =
  38. +         ( NUMARG(.ADD,1,.X) NUMARG(.ADD,2,.Y) )
  39. +         X + Y           :(RETURN)
  40. ADD.END
  41. *
  42.  DEFINE('ADDPROP(UNAME,VAL,PROP)PLT,LST,ELEM,FLAG')
  43.        :(ADDPROP.END)
  44. ADDPROP
  45. *       UNAME = CONVERT(UNAME,'NAME')     :F(ADDPROP.ERROR1)
  46.        (IDENT(PROP)  TDUMP(.ADDPROP,2))
  47.        ( ~ATOM(PROP) NULL(PROP) TDUMP(.ADDPROP,2))
  48.        VAL = IDENT(VAL) NIL
  49.        ADDPROP = NIL
  50.        FLAG = ''
  51.        PLT = $'   PrOpErTy  LiSt  TaBlE   '
  52.        LST = ITEM(PLT,UNAME)
  53.        IDENT(LST)         :S(ADDPROP2)
  54.        ATOM(LST)          :S(ADDPROP.ERROR2)
  55.        NULL(LST)          :S(ADDPROP2)
  56. ADDPROP1
  57.        ELEM = POP( .LST)            :F(ADDPROP2)
  58.        ATOM(ELEM)         :S(ADDPROP.ERROR2)
  59.        ADDPROP = ~EQUAL(CAR(ELEM),PROP)
  60. +         ELEM ~ ADDPROP            :S(ADDPROP1)
  61.        DIFFER(FLAG)            :S(ADDPROP1)
  62.        FLAG = 1
  63.        ADDPROP = MEMQ(VAL,ELEM)
  64. +         ELEM ~ ADDPROP            :S(ADDPROP1)
  65.        ADDPROP = ?( ~ATOM(VAL) NULL(VAL) )
  66. +         ELEM ~ ADDPROP       :S(ADDPROP1)
  67.        ADDPROP = (PROP ~  VAL ~ CDR(ELEM)) ~ ADDPROP
  68. +         :(ADDPROP1)
  69. ADDPROP2
  70.        ADDPROP = DIFFER(FLAG)
  71. +         LREVERSE(ADDPROP)         :S(ADDPROP4)
  72.        ADDPROP = ?( ~ATOM(VAL) NULL(VAL) )
  73. +         (PROP ~ NIL) ~ LREVERSE(ADDPROP)    :S(ADDPROP4)
  74.        ADDPROP = (PROP ~ VAL ~ NIL) ~ LREVERSE(ADDPROP)
  75. ADDPROP4
  76.        ITEM(PLT,UNAME) = ADDPROP   :(RETURN)
  77. ADDPROP.ERROR1
  78.        TDUMP(.ADDPROP,1)
  79. ADDPROP.ERROR2
  80.        |''
  81.        |'Program error:  In ADDPROP,'
  82.        |'a property list is not a list of lists.'
  83.        |'The offending object is '
  84.        |LST
  85.        |''
  86.        TDUMP(.ADDPROP)
  87. ADDPROP.END
  88. *
  89.  DEFINE('ADD1(X)')        :(ADD1.END)
  90. ADD1
  91.       ADD1 = NUMARG(.ADD1,1,.X)    X + 1           :(RETURN)
  92. ADD1.END
  93. *
  94.  DEFINE('APPEND(LOL)L,A')      :(APPEND.END)
  95. APPEND
  96.       APPEND = LISTARG(.APPEND,1,.LOL)    NIL
  97. APPEND1  L = POP( .LOL)       :F(APPEND3)
  98.        LISTARG( .APPEND,  1, .L)
  99. APPEND2  APPEND = POP( .L) ~ APPEND
  100. +    :S(APPEND2)F(APPEND1)
  101. APPEND3   APPEND = LREVERSE(APPEND)       :(RETURN)
  102. APPEND.END
  103. *
  104.  DEFINE('ARITH(OP,ALIST)A')   :(ARITH.END)
  105. ARITH
  106.        (STRINGARG(.ARITH,1,.OP) LISTARG(.ARITH,2,.ALIST))
  107.        ( NULL(ALIST)    TDUMP( .ARITH, 2) )
  108.        ARITH = POP( .ALIST)
  109.        NUMARG( .ARITH, 2, .ARITH)
  110. ARITH1    A = POP( .ALIST)     :F(RETURN)
  111.        NUMARG( .ARITH, 2, .A)
  112.        ARITH = APPLY(OP,ARITH,A)    :S(ARITH1)
  113.        TDUMP( .ARITH)
  114. ARITH.END
  115. *
  116.  DEFINE('ASIN(X)')        :(ASIN.END)
  117. ASIN
  118.        NUMARG( .AS1N,  1, .X)
  119.        (LT(X,-1) TDUMP(.ASIN,1))
  120.        (GT(X,1) TDUMP(.ASIN, 1))
  121.        ASIN = P...I. / 2 - ACOS(X)   :(RETURN)
  122. ASIN.END
  123. *
  124.  DEFINE('ASSOC(TG,L)C')         :(ASSOC.END)
  125. ASSOC
  126.        ASSOC = LISTARG(.ASSOC,2,.L)    NIL
  127. ASSOC1    C = POP( .L) :F(RETURN)
  128.        LISTARG( .ASSOC, 2, .C)
  129.        ASSOC = EQUAL(TG,CAR(C)) C ~ L
  130. +        :S(RETURN)F(ASSOC1)
  131. ASSOC.END
  132. *
  133.  DEFINE('ASSOCL(LTG,L)A')      :(ASSOCL.END)
  134. ASSOCL
  135.        ASSOCL =
  136. +         ( LISTARG(.ASSOCL,1,.LTG) LISTARG(.ASSOCL,2,.L) )
  137. +         NIL
  138. ASSOCL1
  139.        A = POP( .L)        :F(RETURN)
  140.        LISTARG( .ASSOCL,  2, .A)
  141.        ASSOCL = MEMQ(CAR(A),LTG)
  142. +        A ~ L           :S(RETURN)F(ASSOCL1)
  143. ASSOCL.END
  144. *
  145.  DEFINE('ATAN(X)')        :(ATAN.END)
  146. ATAN
  147.        NUMARG( .ATAN, 1,  .X)
  148.        ATAN = LT(X,0) -ATAN( -X)    :S(RETURN)
  149.        ATAN = ACOS(1 / SQRT(1 + X * X))   :(RETURN)
  150. ATAN.END
  151. *
  152.  DEFINE('ATOMP(A)')       :(ATOMP.END)
  153. ATOMP
  154.        ATOMP = NIL
  155.        ATOMP = ATOM(A) T       :(RETURN)
  156. ATOMP.END
  157. *
  158.  DEFINE('CAAAAR(L)')     :(CAAAAR.END)
  159. CAAAAR
  160.        LISTARG( .CAAAAR,  1, .L)
  161.        CAAAAR =
  162. +        (~ATOM(CAR(L))  ~ATOM(CAR(CAR(L))) ~ATOM(CAR(CAR(CAR(L)))))
  163. +             CAR(CAR(CAR(CAR(L))))     :S(RETURN)
  164.        TDUMP(.CAAAAR, 1)
  165. CAAAAR.END
  166. *
  167.  DEFINE('CAAADR(L)')     :(CAAADR.END)
  168. CAAADR
  169.        LISTARG( .CAAADR,  1, .L)
  170.        CAAADR =
  171. +        (~ATOM(CDR(L))  ~ATOM(CAR(CDR(L))) ~ATOM(CAR(CAR(CDR(L)))))
  172. +             CAR(CAR(CAR(CDR(L))))     :S(RETURN)
  173.        TDUMP(.CAAADR, 1)
  174. CAAADR.END
  175. *
  176.  DEFINE('CAAAR(L)')       :(CAAAR.END)
  177. CAAAR
  178.        LISTARG( .CAAAR, 1, .L)
  179.        ( ATOM(CAR(L)) TDUMP( .CAAAR, 1))
  180.        ( ATOM(CAR(CAR(L))) TDUMP(   .CAAAR, 1))
  181.        CAAAR = CAR(CAR(CAR(L)))     :(RETURN)
  182. CAAAR.END
  183. *
  184.  DEFINE('CAADAR(L)')     :(CAADAR.END)
  185. CAADAR
  186.        LISTARG( .CAADAR,  1, .L)
  187.        CAADAR =
  188. +       (~ATOM(CAR(L)) ~ATOM(CDR(CAR(L))) ~ATOM(CAR(CDR(CAR(L)))))
  189. +            CAR(CAR(CDR(CAR(L))))     :S(RETURN)
  190.        TDUMP(.CAADAR, 1)
  191. CAADAR.END
  192. *
  193.  DEFINE('CAADDR(L)')      :(CAADDR.END)
  194. CAADDR
  195.        LISTARG( .CAADDR, 1,  .L)
  196.        CAADDR =
  197. +       (~ATOM(CDR(L))  ~ATOM(CDR(CDR(L))) ~ATOM(CAR(CDR(CDR(L)))))
  198. +            CAR(CAR(CDR(CDR(L))))     :S(RETURN)
  199.        TDUMP(.CAADDR, 1)
  200. CAADDR.END
  201. *
  202.  DEFINE('CAADR(L)')       :(CAADR.END)
  203. CAADR
  204.        LISTARG(  .CAADR, 1, .L)
  205.        ( ATOM(CDR(L)) TDUMP( .CAADR, 1))
  206.        ( ATOM(CAR(CDR(L))) TDUMP(   .CAADR, 1))
  207.        CAADR = CAR(CAR(CDR(L)))     :(RETURN)
  208. CAADR.END
  209. *
  210.  DEFINE('CAAR(L)')       :(CAAR.END)
  211. CAAR
  212.        LISTARG(  .CAAR, 1, .L)
  213.        ( ATOM(CAR(L)) TDUMP(  .CAAR, 1))
  214.        CAAR =  CAR(CAR(L))      :(RETURN)
  215. CAAR.END
  216. *
  217.  DEFINE('CADAAR(L)')    :(CADAAR.END)
  218. CADAAR
  219.        LISTARG(  .CADAAR, 1, .L)
  220.        CADAAR =
  221. +       (~ATOM(CAR(L)) ~ATOM(CAR(CAR(L))) ~ATOM(CDR(CAR(CAR(L)))))
  222. +            CAR(CDR(CAR(CAR(L))))     :S(RETURN)
  223.        TDUMP( .CADAAR, 1)
  224. CADAAR.END
  225. *
  226.  DEFINE('CADADR(L)')      :(CADADR.END)
  227. CADADR
  228.        LISTARG( .CADADR,   1, .L)
  229.        CADADR =
  230. +       (~ATOM(CDR(L))  ~ATOM(CAR(CDR(L))) ~ATOM(CDR(CAR(CDR(L)))))
  231. +            CAR(CDR(CAR(CDR(L))))     :S(RETURN)
  232.        TDUMP(.CADADR, 1)
  233. CADADR.END
  234. *
  235.  DEFINE('CADAR(L)')       :(CADAR.END)
  236. CADAR
  237.        LISTARG(  .CADAR, 1, .L)
  238.        ( ATOM(CAR(L)) TDUMP(  .CADAR, 1))
  239.        ( ATOM(CDR(CAR(L))) TDUMP(   .CADAR, 1))
  240.        CADAR = CAR(CDR(CAR(L)))     :(RETURN)
  241. CADAR.END
  242. *
  243.  DEFINE('CADDAR(L)')       :(CADDAR.END)
  244. CADDAR
  245.        LISTARG(.CADDAR,1,.L)
  246.        CADDAR =
  247. +         (~ATOM(CAR(L))  ~ATOM(CDR(CAR(L))) ~ATOM(CDR(CDR(CAR(L)))))
  248. +              CAR(CDR(CDR(CAR(L))))     :S(RETURN)
  249.        TDUMP(.CADDAR, 1)
  250. CADDAR.END
  251. *
  252.  DEFINE('CADDDR(L)')       :(CADDDR.END)
  253. CADDDR
  254.        LISTARG(.CADDDR, 1, .L)
  255.        CADDDR =
  256. +         (~ATOM(CDR(L))  ~ATOM(CDR(CDR(L))) ~ATOM(CDR(CDR(CDR(L)))))
  257. +              CAR(CDR(CDR(CDR(L))))     :S(RETURN)
  258.        TDUMP(.CADDDR,1)
  259. CADDDR.END
  260. *
  261.  DEFINE('CADDR(L)')        :(CADDR.END)
  262. CADDR
  263.        LISTARG( .CADDR, 1, .L)
  264.        ( ATOM(CDR(L)) TDUMP( .CADDR,  1))
  265.        ( ATOM(CDR(CDR(L))) TDUMP( .CADDR, 1))
  266.        CADDR = CAR(CDR(CDR(L)))    :(RETURN)
  267. CADDR.END
  268. *
  269.  DEFINE('CADR(L)')       :(CADR.END)
  270. CADR
  271.        LISTARG( .CADR, 1, .L)
  272.        ( ATOM(CDR(L)) TDUMP( .CADR,  1))
  273.        CADR =  CAR(CDR(L))      :(RETURN)
  274. CADR.END
  275. *
  276.  DEFINE('CAL(A)N')        :(CAL.END)
  277. CAL
  278.        (DIFFER('ARRAY',DATATYPE(A)) TDUMP( .CAL, 1))
  279.        CAL = NIL
  280.        N  = PROTOTYPE(A)
  281.        N  = CONVERT(N,'INTEGER')    :S(CAL1)
  282.        TDUMP( .CAL, 1)
  283. CAL1   GT(N,0)        :F(RETURN)
  284.        CAL = A<N> ~ CAL
  285.        N = N -  1          :(CAL1)
  286. CAL.END
  287. *
  288.  DEFINE('CDAAAR(L)')      :(CDAAAR.END)
  289. CDAAAR
  290.        LISTARG( .CDAAAR,  1, .L)
  291.        CDAAAR =
  292. +         (~ATOM(CAR(L)) ~ATOM(CAR(CAR(L))) ~ATOM(CAR(CAR(CAR(L)))))
  293. +             CDR(CAR(CAR(CAR(L))))     :S(RETURN)
  294.        TDUMP(.CDAAAR,1)
  295. CDAAAR.END
  296. *
  297.  DEFINE('CDAADR(L)')      :(CDAADR.END)
  298. CDAADR
  299.        LISTARG(.CDAADR,1,.L)
  300.        CDAADR =
  301. +         (~ATOM(CDR(L)) ~ATOM(CAR(CDR(L))) ~ATOM(CAR(CAR(CDR(L)))))
  302. +             CDR(CAR(CAR(CDR(L))))     :S(RETURN)
  303.        TDUMP(.CDAADR,1)
  304. CDAADR.END
  305. *
  306.  DEFINE('CDAAR(L)')       :(CDAAR.END)
  307. CDAAR
  308.        LISTARG( .CDAAR, 1, .L)
  309.        ( ATOM(CAR(L)) TDUMP( .CDAAR,  1))
  310.        ( ATOM(CAR(CAR(L))) TDUMP( .CDAAR, 1))
  311.        CDAAR = CDR(CAR(CAR(L)))     :(RETURN)
  312. CDAAR.END
  313. *
  314.  DEFINE('CDADAR(L)')      :(CDADAR.END)
  315. CDADAR
  316.        LISTARG(.CDADAR,1,.L)
  317.        CDADAR =
  318. +         (~ATOM(CAR(L)) ~ATOM(CDR(CAR(L))) ~ATOM(CAR(CDR(CAR(L)))))
  319. +             CDR(CAR(CDR(CAR(L))))     :S(RETURN)
  320.        TDUMP(.CDADAR,1)
  321. CDADAR.END
  322. *
  323.  DEFINE('CDADDR(L)')      :(CDADDR.END)
  324. CDADDR
  325.        LISTARG(.CDADDR, 1, .L)
  326.        CDADDR =
  327. +         (~ATOM(CDR(L)) ~ATOM(CDR(CDR(L))) ~ATOM(CAR(CDR(CDR(L)))))
  328. +             CDR(CAR(CDR(CDR(L))))     :S(RETURN)
  329.        TDUMP(.CDADDR,1)
  330. CDADDR.END
  331. *
  332.  DEFINE('CDADR(L)')     :(CDADR.END)
  333. CDADR
  334.        LISTARG( .CDADR, 1, .L)
  335.        ( ATOM(CDR(L)) TDUMP( .CDADR, 1))
  336.        ( ATOM(CAR(CDR(L))) TDUMP( .CDADR, 1))
  337.        CDADR = CDR(CAR(CDR(L)))      :(RETURN)
  338. CDADR.END
  339. *
  340.  DEFINE('CDAR(L)')        :(CDAR.END)
  341. CDAR
  342.        LISTARG( .CDAR, 1, .L)
  343.        ( ATOM(CAR(L)) TDUMP( .CDAR,  1))
  344.        CDAR =  CDR(CAR(L))      :(RETURN)
  345. CDAR.END
  346. *
  347.  DEFINE('CDDAAR(L)')     :(CDDAAR.END)
  348. CDDAAR
  349.        LISTARG(.CDDAAR,1,.L)
  350.        CDDAAR =
  351. +         (~ATOM(CAR(L)) ~ATOM(CAR(CAR(L))) ~ATOM(CDR(CAR(CAR(L)))))
  352. +              CDR(CDR(CAR(CAR(L))))     :S(RETURN)
  353.        TDUMP(.CDDAAR,1)
  354. CDDAAR.END
  355. *
  356.  DEFINE('CDDADR(L)')      :(CDDADR.END)
  357. CDDADR
  358.        LISTARG(.CDDADR, 1, .L)
  359.        CDDADR =
  360. +         (~ATOM(CDR(L)) ~ATOM(CAR(CDR(L))) ~ATOM(CDR(CAR(CDR(L)))))
  361. +              CDR(CDR(CAR(CDR(L))))     :S(RETURN)
  362.        TDUMP(.CDDADR,1)
  363. CDDADR.END
  364. *
  365.  DEFINE('CDDAR(L)')      :(CDDAR.END)
  366. CDDAR
  367.        LISTARG( .CDDAR, 1, .L)
  368.        ( ATOM(CAR(L)) TDUMP( .CDDAR, 1))
  369.        ( ATOM(CDR(CAR(L))) TDUMP( .CDDAR, 1))
  370.        CDDAR = CDR(CDR(CAR(L)))     :(RETURN)
  371. CDDAR.END
  372. *
  373.  DEFINE('CDDDAR(L)')     :(CDDDAR.END)
  374. CDDDAR
  375.        LISTARG(.CDDDAR, 1, .L)
  376.        CDDDAR =
  377. +         (~ATOM(CAR(L)) ~ATOM(CDR(CAR(L))) ~ATOM(CDR(CDR(CAR(L)))))
  378. +              CDR(CDR(CDR(CAR(L))))     :S(RETURN)
  379.        TDUMP(.CDDDAR,1)
  380. CDDDAR.END
  381. *
  382.  DEFINE('CDDDDR(L)')      :(CDDDDR.END)
  383. CDDDDR
  384.        LISTARG(.CDDDDR,1,.L)
  385.        CDDDDR =
  386. +         (~ATOM(CDR(L)) ~ATOM(CDR(CDR(L))) ~ATOM(CDR(CDR(CDR(L)))))
  387. +              CDR(CDR(CDR(CDR(L))))     :S(RETURN)
  388.        TDUMP(.CDDDDR,1)
  389. CDDDDR.END
  390. *
  391.  DEFINE('CDDDR(L)')       :(CDDDR.END)
  392. CDDDR
  393.        LISTARG( .CDDDR, 1, .L)
  394.        ( ATOM(CDR(L)) TDUMP( .CDDDR, 1))
  395.        ( ATOM(CDR(CDR(L))) TDUMP( .CDDDR, 1))
  396.        CDDDR = CDR(CDR(CDR(L)))     :(RETURN)
  397. CDDDR.END
  398. *
  399.  DEFINE('CDDR(L)')        :(CDDR.END)
  400. CDDR
  401.        LISTARG( .CDDR, 1, .L)
  402.        ( ATOM(CDR(L)) TDUMP( .CDDR, 1))
  403.        CDDR = CDR(CDR(L))      :(RETURN)
  404. CDDR.END
  405. *
  406.  DEFINE('CEIL(X)')       :(CEIL.END)
  407. CEIL
  408.        NUMARG( .CEIL, 1, .X)
  409.        CEIL = -FLOOR( -X) :(RETURN)
  410. CEIL.END
  411. *
  412.  DEFINE('CLA(L)N')        :(CLA.END)
  413. CLA
  414.        N = LISTARG(.CLA,1,.L)   LENGTH(L)
  415.        ( LE(N,0)   TDUMP( .CLA, 1)  )
  416.        CLA = ARRAY(N)
  417.        N = 1
  418. CLA1  CLA<N> = POP( .L)        :F(RETURN)
  419.        N = N + 1     :(CLA1)
  420. CLA.END
  421. *
  422.  DEFINE('CLOG(X)FACTOR,T,K')        :(CLOG.END)
  423. CLOG
  424.        NUMARG( .CLOG, 1, .X)
  425.        (LE(X,0) TDUMP( .CLOG, 1))
  426.        CLOG = LN(X) / LN...10.   :(RETURN)
  427. CLOG.END
  428. *
  429.  DEFINE('COS(A,S)K')         :(COS.END)
  430. COS
  431.        ( NUMARG(.COS,1,.A) DIFFER(S) NUMARG(.COS,2,.S) )
  432.        (LT(S, -1) TDUMP( .COS, 2))
  433.        (GT(S, 1) TDUMP( .COS, 2))
  434.        COS = LT(A,0) COS( -A, S)   :S(RETURN)
  435.        COS = LT(A, 2 * P...I.) COS.( A, S)    :S(RETURN)
  436.        K = FIX( A / (2 * P...I.))
  437.        COS = COS.( A - K  * 2  * P...I., S)   :(RETURN)
  438. COS.
  439.        S = IDENT(S)  SIN(A)
  440.        COS. = SQRT( 1  - S * S)
  441.        P2 = P...I. / 2
  442.        COS. = (GT(A,P2) LT(A,3 * P2)) -COS.   :(RETURN)
  443. COS.END
  444. *
  445.  DEFINE('DEFPROP(A1,EXP,A2)')       :(DEFPROP.END)
  446. DEFPROP
  447.        DEFPROP = PUT(A1,A2,EXP)     :(RETURN)
  448. DEFPROP.END
  449. *
  450.  DEFINE('DEG(R)')    :(DEG.END)
  451. DEG
  452.        DEG = NUMARG(.DEG,1,.R)   R * 57.2957795131        :(RETURN)
  453. DEG.END
  454. *
  455.  DEFINE('DFLOAT(N)')      :(DFLOAT.END)
  456. DFLOAT
  457.        NUMARG( .DFLOAT, 1, .N)
  458.        DFLOAT = CONVERT(N,"REAL")   :(RETURN)
  459. DFLOAT.END
  460. *
  461.  DEFINE('DIFFERENCE(L)')       :(DIFFERENCE.END)
  462. DIFFERENCE
  463.        DIFFERENCE =  LISTARG(.DIFFERENCE,1,.L)
  464. +         ARITH(.SUB,L)        :(RETURN)
  465. DIFFERENCE.END
  466. *
  467.  DEFINE('DIV(X,Y)')       :(DIV.END)
  468. DIV
  469.        (NUMARG(.DIV,1,.X) NUMARG(.DIV,2,.Y))
  470. *      (EQ(Y,0) TDUMP(.DIV,2))      :S(FRETURN)
  471.        DIV = DFLOAT(X) /  DFLOAT(Y)      :(RETURN)
  472. DIV.END
  473. *
  474.  DEFINE('EQP(A1,A2)')       :(EQP.END)
  475. EQP
  476.        EQP = NIL
  477.        EQP = EQU(A1,A2) T      :(RETURN)
  478. EQP.END
  479. *
  480.  DEFINE('EQU(A1,A2)')     :(EQU.END)
  481. EQU    IDENT(A1,A2)       :S(RETURN)
  482.        ( ATOM(A1)    ATOM(A2) )          :F(FRETURN)
  483.        ( NUMBER(A1)  NUMBER(A2) )        :F(EQU1)
  484.        EQ(A1,A2)               :S(RETURN)F(FRETURN)
  485. EQU1   LEQ(A1,A2)              :S(RETURN)F(FRETURN)
  486. EQU.END
  487. *
  488.  DEFINE('EQUAL(X,Y)')   :(EQUAL.END)
  489. EQUAL  EQU(X,Y)      :S(RETURN)
  490.        ATOM(X)                 :S(FRETURN)
  491.        ATOM(Y)                 :S(FRETURN)
  492.        EQUAL(CAR(X),CAR(Y))    :F(FRETURN)
  493.        EQUAL(CDR(X),CDR(Y))         :S(RETURN)F(FRETURN)
  494. EQUAL.END
  495. *
  496.  DEFINE('EQUALP(A1,A2)')       :(EQUALP.END)
  497. EQUALP
  498.        EQUALP = NIL
  499.        EQUALP = EQUAL(A1,A2) T      :(RETURN)
  500. EQUALP.END
  501. *
  502.  DEFINE('EVALCODE(S)')   :(EVALCODE.END)
  503. EVALCODE
  504.        S = CONVERT(S,"EXPRESSION")    :F(EVALCODE1)
  505.        EVALCODE = EVAL(S)      :S(RETURN)F(FRETURN)
  506. EVALCODE1
  507.        TDUMP('EVALCODE',1)
  508. EVALCODE.END
  509. *
  510.  DEFINE('EVERY(FN,L)A,V')   :(EVERY.END)
  511. EVERY
  512.        EVERY =
  513. +         (STRINGARG(.EVERY,1,.FN) LISTARG(.EVERY,2,.L))
  514. +         T
  515. EVERY1  A = POP( .L)   :F(RETURN)
  516.        %APPLY(FN,A)       :S(EVERY1)
  517.        EVERY = NIL  :(RETURN)
  518. EVERY.END
  519. *
  520.  DEFINE('EVLIS(EV...L.)EV...T.')         :(EVLIS.END)
  521. EVLIS
  522.        EVLIS = LISTARG( .EVLIS, 1, .EV...L. )   NIL
  523. EVLIS1
  524.        EV...T.  = POP( .EV...L. )        :F(EVLIS2)
  525.        EVLIS = $EV...T. ~ EVLIS          :(EVLIS1)
  526. EVLIS2
  527.        EVLIS = LREVERSE(EVLIS)           :(RETURN)
  528. EVLIS.END
  529. *
  530.  DEFINE('EXCLUDE(L,XCL)A')   :(EXCLUDE.END)
  531. EXCLUDE
  532.        EXCLUDE =
  533. +        (LISTARG(.EXCLUDE,1,.L) LISTARG(.EXCLUDE,2,.XCL))
  534. +        NIL
  535. EXCLUDE1      A = POP( .L)  :F(EXCLUDE2)
  536.        EXCLUDE  = ~MEMQ(A,XCL) INSERT(A,EXCLUDE)     :(EXCLUDE1)
  537. EXCLUDE2      EXCLUDE = LREVERSE(EXCLUDE)     :(RETURN)
  538. EXCLUDE.END
  539. *
  540.  DEFINE('EXPLODE(A)CH')       :(EXPLODE.END)
  541. EXPLODE
  542.        EXPLODE = NIL
  543.        A = ~ATOM(A) UNREAD(A)
  544.        A = REVERSE(A)       :F(EXPLODE2)
  545. EXPLODE1
  546.        A LEN(1) . CH =    :F(RETURN)
  547.        EXPLODE = LIST(CH,EXPLODE)    :(EXPLODE1)
  548. EXPLODE2
  549.        TDUMP( .EXPLODE, 1)
  550. EXPLODE.END
  551. *
  552.  DEFINE('FIND(TG,L)')    :(FIND.END)
  553. FIND
  554.        ATOM(L)       :F(FIND1)
  555.        FIND = EQU(L,TG) L      :S(RETURN)
  556.        FIND = NIL    :(RETURN)
  557. FIND1  FIND = NULL(L) NIL  :S(RETURN)
  558.        FIND = EQUAL(L,TG) L    :S(RETURN)
  559.        FIND = /FIND(TG,CAR(L))       :S(RETURN)
  560.        FIND = FIND(TG,CDR(L))        :(RETURN)
  561. FIND.END
  562. *
  563.  DEFINE('FIX(X)')   :(FIX.END)
  564. FIX
  565.        FIX = NUMARG(.FIX,1,.X) CONVERT(X,'INTEGER')
  566. +         :S(RETURN)F(FRETURN)
  567. FIX.END
  568. *
  569.  DEFINE('FLOAT(N)')      :(FLOAT.END)
  570. FLOAT
  571.        FLOAT = NUMARG(.FLOAT,1,.N)   CONVERT(N,'REAL')    :(RETURN)
  572. FLOAT.END
  573. *
  574.  DEFINE('FLOOR(X)')      :(FLOOR.END)
  575. FLOOR
  576.        NUMARG( .FLOOR, 1, .X)
  577.        FLOOR = FIX(X)
  578.        GE(X)    :S(RETURN)
  579.        FLOOR = NE(X,FLOOR) FLOOR - 1     :(RETURN)
  580. FLOOR.END
  581. *
  582.  DEFINE('GENSYM()')      :(GENSYM.END)
  583. GENSYM
  584. +      GENSYM = 'GSYM' STATEMENTS(0)
  585.        IDENT($GENSYM)     :S(RETURN)F(GENSYM)
  586. GENSYM.END
  587. *
  588.  DEFINE('GET(UNAME,PROP)PLT,LST,ELEM')       :(GET.END)
  589. GET
  590. *       UNAME = CONVERT(UNAME,'NAME')    :F(GET.ERROR1)
  591.        (IDENT(PROP) TDUMP(.GET,2))
  592.        ( ~ATOM(PROP) NULL(PROP) TDUMP(.GET,2) )
  593.        GET = NIL
  594.        PLT = $'   PrOpErTy  LiSt  TaBlE   '
  595.        LST = ITEM(PLT,UNAME)
  596.        IDENT(LST)         :S(RETURN)
  597.        ATOM(LST)          :S(GET.ERROR2)
  598.        NULL(LST)          :S(RETURN)
  599. GET1
  600.        ELEM = POP( .LST)            :F(RETURN)
  601.        ATOM(ELEM)         :S(GET.ERROR2)
  602.        GET = EQUAL(CAR(ELEM),PROP)
  603. +         CDR(ELEM)             :S(RETURN)F(GET1)
  604. GET.ERROR1
  605.        TDUMP(.GET,1)
  606. GET.ERROR2
  607.        |''
  608.        |'Program error:  In GET,'
  609.        |'a property list is not a list of lists.'
  610.        |'The offending object is'
  611.        |LST
  612.        |''
  613.        TDUMP(.GET)
  614. GET.END
  615. *
  616.  DEFINE('GETL(UNAME,LPROP)PLT,LST,ELEM')       :(GETL.END)
  617. GETL
  618. *       UNAME = CONVERT(UNAME,'NAME')     :F(GETL.ERROR1)
  619.        LISTARG( .GETL, 2, .LPROP)
  620.        GETL = NIL
  621.        PLT = $'   PrOpErTy  LiSt  TaBlE   '
  622.        LST = ITEM(PLT,UNAME)
  623.        IDENT(LST)         :S(RETURN)
  624.        ATOM(LST)          :S(GETL.ERROR2)
  625.        NULL(LST)          :S(RETURN)
  626. GETL1
  627.        ELEM = POP( .LST)            :F(RETURN)
  628.        ATOM(ELEM)         :S(GETL.ERROR2)
  629.        GETL = MEMQ(CAR(ELEM),LPROP)
  630. +         ELEM ~ LST             :S(RETURN)F(GETL1)
  631. GETL.ERROR1
  632.        TDUMP(.GETL,1)
  633. GETL.ERROR2
  634.        |''
  635.        |'Program error:   In GETL,'
  636.        |'a property list is not a list of lists.'
  637.        |'The offending object is'
  638.        |LST
  639.        |''
  640.        TDUMP(.GETL)
  641. GETL.END
  642. *
  643.  DEFINE('GETPROP(UNAME,PROP)PLT,LST,ELEM,FLAG,NEW') :(GETPROP.END)
  644. GETPROP
  645. *       UNAME = CONVERT(UNAME,'NAME')    :F(GETPROP.ERROR1)
  646.        (IDENT(PROP) TDUMP(.GETPROP,2))
  647.        ( ~ATOM(PROP) NULL(PROP) TDUMP(.GETPROP,2) )
  648.        PLT = $'   PrOpErTy  LiSt  TaBlE   '
  649.        GETPROP = NIL
  650.        FLAG = ''
  651.        LST = ITEM(PLT,UNAME)
  652.        IDENT(LST)         :S(RETURN)
  653.        ATOM(LST)          :S(GETPROP.ERROR2)
  654.        NULL(LST)          :S(RETURN)
  655.        NEW = NIL
  656. GETPROP1
  657.        ELEM = POP( .LST)            :F(GETPROP2)
  658.        ATOM(ELEM)         :S(GETPROP.ERROR2)
  659.        NEW = ~EQUAL(CAR(ELEM),PROP)
  660. +         ELEM ~ NEW      :S(GETPROP1)
  661.        DIFFER(FLAG)       :S(GETPROP1)
  662.        FLAG = 1
  663.        ELEM = CDR(ELEM)
  664.        GETPROP = POP( .ELEM)
  665.        NEW = (PROP ~ ELEM) ~ NEW    :(GETPROP1)
  666. GETPROP2
  667.        ITEM(PLT,UNAME) = LREVERSE(NEW)  :(RETURN)
  668. GETPROP.ERROR1
  669.        TDUMP(.GETPROP,1)
  670. GETPROP.ERROR2
  671.        |''
  672.        |'Program error:   In GETPROP,'
  673.        |'a property list is not a list of lists.'
  674.        |'The offending object is'
  675.        |LST
  676.        |''
  677.        TDUMP(.GETPROP)
  678. GETPROP.END
  679. *
  680.  DEFINE('GREATER(L)A,B')       :(GREATER.END)
  681. GREATER
  682.        LISTARG( .GREATER, 1, .L)
  683.        A = POP( .L)       :F(RETURN)
  684.        NUMARG( .GREATER,  1, .A)
  685.        B = POP( .L)       :F(RETURN)
  686.        NUMARG( .GREATER,  1, .B)
  687. GREATER1     GT(A,B)      :F(FRETURN)
  688.        A = B
  689.        B = POP( .L)       :F(RETURN)
  690.        NUMARG( .GREATER,  1, .B)    :S(GREATER1)
  691. GREATER.END
  692. *
  693.  DEFINE('GREATERP(L)')    :(GREATERP.END)
  694. GREATERP
  695.        GREATERP =
  696. +         (LISTARG(.GREATERP,1,.L)  GREATER(L))
  697. +         T          :S(RETURN)
  698.        GREATERP = NIL          :(RETURN)
  699. GREATERP.END
  700. *
  701.  DEFINE('INSERT(S,L)')    :(INSERT.END)
  702. INSERT
  703.        LISTARG(.INSERT,2,.L)
  704.        INSERT = MEMQ(S,L) L    :S(RETURN)
  705.        INSERT = S ~ L          :(RETURN)
  706. INSERT.END
  707. *
  708.  DEFINE('INTERSECT(L1,L2)L,A')     :(INTERSECT.END)
  709. INTERSECT
  710.        INTERSECT =
  711. +         (LISTARG(.INTERSECT,1,.L1) LISTARG(.INTERSECT,2,.L2))
  712. +         NIL
  713. INTERSECT1    A = POP( .L1)      :F(INTERSECT2)
  714.        INTERSECT = MEMQ(A,L2) INSERT(A,INTERSECT)      :(INTERSECT1)
  715. INTERSECT2     INTERSECT = LREVERSE(INTERSECT)     :(RETURN)
  716. INTERSECT.END
  717. *
  718.  DEFINE('LAST(L)')        :(LAST.END)
  719. LAST
  720.        LISTARG( .LAST, 1, .L)
  721.        LAST = NULL(L) NIL      :S(RETURN)
  722.        LAST = ATOM( CDR(L)) L       :S(RETURN)
  723.        LAST = NULL( CDR(L)) L       :S(RETURN)
  724.        L = CDR(L)    :(LAST)
  725. LAST.END
  726. *
  727.  DEFINE('LCOPY(L)CA,CD')       :(LCOPY.END)
  728. LCOPY
  729.        LCOPY = ATOM(L) L       :S(RETURN)
  730.        LCOPY = NULL(L) NIL     :S(RETURN)
  731.        LCOPY = EQUAL(L,T) T    :S(RETURN)
  732.        CA = LCOPY(CAR(L))
  733.        CD = LCOPY(CDR(L))
  734.        LCOPY = CA ~ CD         :(RETURN)
  735. LCOPY.END
  736. *
  737.  DEFINE('LENGTH(L)')     :(LENGTH.END)
  738. LENGTH    LENGTH = ATOM(L) SIZE(L)        :S(RETURN)
  739.        LENGTH = 0
  740. LENGTH1  LENGTH = ?POP( .L)    LENGTH + 1
  741. +      :S(LENGTH1)F(RETURN)
  742. LENGTH.END
  743. *
  744.  DEFINE('LESS(L)A,B')     :(LESS.END)
  745. LESS
  746.        LISTARG( .LESS, 1, .L)
  747.        A = POP( .L)        :F(RETURN)
  748.        NUMARG( .LESS, 1, .A)
  749.        B = POP( .L)        :F(RETURN)
  750.        NUMARG( .LESS, 1, .B)
  751. LESS1     LT(A,B)    :F(FRETURN)
  752.        A = B
  753.        B = POP( .L)      :F(RETURN)
  754.        NUMARG( .LESS, 1, .B)  :S(LESS1)
  755. LESS.END
  756. *
  757.  DEFINE('LESSP(L)')       :(LESSP.END)
  758. LESSP
  759.        LISTARG( .LESSP, 1, .L)
  760.        LESSP = NIL
  761.        LESSP = LESS(L) T       :(RETURN)
  762. LESSP.END
  763. *
  764.  DEFINE('LOG(X,B)')      :(LOG.END)
  765. LOG
  766.        NUMARG(.LOG,1,.X)
  767.        (DIFFER(B) NUMARG(.LOG,2,.B))
  768.        (LE(X,0) TDUMP(.LOG,1))
  769.        (LT(B,0) TDUMP(.LOG,2))
  770.        (EQ(B,1) TDUMP(.LOG,2))
  771.        LOG = NE(B) LN(X) / LN(B)       :S(RETURN)
  772.        LOG = EQ(B) LN(X)                  :(RETURN)
  773. LOG.END
  774. *
  775.  DEFINE('LREVERSE(LST)')      :(LREVERSE.END)
  776. LREVERSE
  777.        LREVERSE = LISTARG(.LREVERSE,1,.LST)   NIL
  778. LREVERSE1 LREVERSE = POP( .LST) ~ LREVERSE
  779. +      :S(LREVERSE1)F(RETURN)
  780. LREVERSE.END
  781. *
  782.  DEFINE('LTRACE(PARAM,L)F,TFNAME')      :(LTRACE.END)
  783. LTRACE
  784.        L = IDENT(L) PARAM
  785.        PARAM = ~INTEGER(PARAM) 3
  786.        INTARG( .LTRACE, 1, .PARAM)
  787.        LISTARG( .LTRACE, 2, .L)
  788.        F = POP( .L)       :F(RETURN)
  789.        STRINGARG( .LTRACE, 2, .F)
  790.        F POS(0) 'LAMBDA'     :S(LTRACE)
  791.        F POS(0)
  792. +         (
  793. +             'LTRACE' |
  794. +             'LTRACE1' |
  795. +             'POP' |
  796. +             'PRT.VIA.OUTPUT' |
  797. +             'PRINT' |
  798. +             'ATOM' |
  799. +             ('C' SPAN('AD') 'R') |
  800. +             'TDUMP' |
  801. +             'INTARG' |
  802. +             'NUMARG' |
  803. +             'LISTARG' |
  804. +             'STRINGARG' |
  805. +             'PRINT.IN.FIELD' |
  806. +             'UNREAD' |
  807. +             'NULL' |
  808. +             'UNCONS' |
  809. +             'IN' |
  810. +             'CONCAT' |
  811. +             'MAPCAR' |
  812. +             'LIST' |
  813. +             'UNREAD.NIL' |
  814. +             'UNREAD.DOTPAIR' |
  815. +             'UNREAD.SINGLETON' |
  816. +             'UNREAD.REGULAR' |
  817. +             'UNREAD.ATOM'
  818. +         ) RPOS(0)            :S(LTRACE)
  819.        ( EQ(PARAM,0) STOPTR(F,'CALL') STOPTR(F,'RETURN') )    :S(LTRACE)
  820. LTRACE.A
  821.        TRACE(F,"CALL",,
  822. +         DEXP('LAMBDA() = LTRACE1(.' F ',"CALL",' PARAM ')'))
  823.        TRACE(F,"RETURN",,
  824. +         DEXP('LAMBDA() = LTRACE1(.' F ',"RETURN",' PARAM ')'))
  825. +         :(LTRACE)
  826. *
  827. LTRACE1
  828.        IDENT(LTRACE1...T.,"RETURN")    :S(LTRACE1.B)
  829.        |""
  830.        |(">>> " &LASTNO " ==> " &STNO " ==> " )
  831.        |(" " LTRACE1...F.)
  832.        LTRACE1...I. = 1
  833. LTRACE1.A     LTRACE1...N. = ARG(LTRACE1...F.,LTRACE1...I.)  :F(LTRACE1.F)
  834.        |(5 % " " LTRACE1...N. " = ")
  835.        |(7 % " " !($LTRACE1...N.))
  836.        LTRACE1...I. = LTRACE1...I. + 1     :(LTRACE1.A)
  837. LTRACE1.B |""
  838.        |("<<< " &RTNTYPE " <== " &STNO " <== " &LASTNO)
  839.        |(" " LTRACE1...F. " = ")
  840.        |(5 % " " !($LTRACE1...F.))     LE(LTRACE1...L.,1)   :S(RETURN)
  841.        LTRACE1...I. = 1
  842. LTRACE1.C     LTRACE1...N. = ARG(LTRACE1...F.,LTRACE1...I.)  :F(LTRACE1.D)
  843.        LEQ(LTRACE1...N.,LTRACE1...F.)      :S(LTRACE1.C)
  844.        |(5 % " " LTRACE1...N. " = ")
  845.        |(7 % " " !($LTRACE1...N.))
  846.        LTRACE1...I. = LTRACE1...I. + 1     :(LTRACE1.C)
  847. LTRACE1.D LTRACE1...I. = 1
  848. LTRACE1.E LTRACE1...N. = LOCAL(LTRACE1...F.,LTRACE1...I.)  :F(LTRACE1.F)
  849.        LEQ(LTRACE1...N.,LTRACE1...F.)      :S(LTRACE1.E)
  850.        |(5 % " " LTRACE1...N. " = ")
  851.        |(7 % " " !($LTRACE1...N.))
  852.        LTRACE1...I. = LTRACE1...I. + 1     :(LTRACE1.E)
  853. LTRACE1.F      ( GE(LTRACE1...L.,3) ?EVAL(IN()) )      :(RETURN)
  854. LTRACE.END
  855. *
  856.  DEFINE('MAP(FN,L)')     :(MAP.END)
  857. MAP
  858.        MAP =
  859. +         (STRINGARG(.MAP,1,.FN) LISTARG(.MAP,2,.L))
  860. +         NIL
  861. MAP1   NULL(L)       :S(RETURN)
  862.        APPLY(FN,L)   :F(FRETURN)
  863.        L = CDR(L)    :(MAP1)
  864. MAP.END
  865. *
  866.  DEFINE('MAPC(FN,L)')     :(MAPC.END)
  867. MAPC
  868.        MAPC =
  869. +         (STRINGARG(.MAPC,1,.FN) LISTARG(.MAPC,2,.L))
  870. +         NIL
  871. MAPC1     NULL(L)    :S(RETURN)
  872.        APPLY(FN, POP( .L))   :F(FRETURN)S(MAPC1)
  873. MAPC.END
  874. *
  875.  DEFINE('MAPCAN(FN,L)')       :(MAPCAN.END)
  876. MAPCAN
  877.        (STRINGARG(.MAPCAN,1,.FN) LISTARG(.MAPCAN,2,.L))
  878.        MAPCAN = NCONC(MAPCAR(FN,L))     :(RETURN)
  879. MAPCAN.END
  880. *
  881.  DEFINE('MAPCON(FN,L)')       :(MAPCON.END)
  882. MAPCON
  883.        MAPCON  = NCONC(MAPLIST(FN,L))     :(RETURN)
  884. MAPCON.END
  885. *
  886.  DEFINE('MAPLIST(FN,L)R')     :(MAPLIST.END)
  887. MAPLIST
  888.        MAPLIST =
  889. +      (STRINGARG(.MAPLIST,1,.FN) LISTARG(.MAPLIST,2,.L))
  890. +      NIL
  891. MAPLIST1       NULL(L)    :S(MAPLIST2)
  892.        R  = APPLY(FN,L)     :F(FRETURN)
  893.        MAPLIST = R ~ MAPLIST
  894.        L  = CDR(L)   :(MAPLIST1)
  895. MAPLIST2       MAPLIST = LREVERSE(MAPLIST)     :(RETURN)
  896. MAPLIST.END
  897. *
  898.  DEFINE('MAX(X,Y)')       :(MAX.END)
  899. MAX
  900.        (NUMARG(.MAX,1,.X) NUMARG(.MAX,2,.Y))
  901.        MAX = GE(X,Y) X    :S(RETURN)
  902.        MAX = Y       :(RETURN)
  903. MAX.END
  904. *
  905.  DEFINE('MEMBER(A,MBR)') :(MEMBER.END)
  906. MEMBER
  907.        MEMBER = LISTARG(.MEMBER,2,.MBR)    NIL
  908. MEMBER1  EQUAL(A,CAR(MBR))    :S(MEMBER2)
  909.        POP( .MBR)   :S(MEMBER1)F(RETURN)
  910. MEMBER2   MEMBER = MBR    :(RETURN)
  911. MEMBER.END
  912. *
  913.  DEFINE('MEMQ(A,L)')     :(MEMQ.END)
  914. MEMQ
  915.        (LISTARG( .MEMQ, 2, .L)
  916. +      %MEMBER(A,L))      :S(RETURN)F(FRETURN)
  917. MEMQ.END
  918. *
  919.  DEFINE('MIN(X,Y)')       :(MIN.END)
  920. MIN
  921.        (NUMARG(.MIN,1,.X) NUMARG(.MIN,2,.Y))
  922.        MIN = LE(X,Y) X    :S(RETURN)
  923.        MIN = Y       :(RETURN)
  924. MIN.END
  925. *
  926.  DEFINE('MINUS(X)')     :(MINUS.END)
  927. MINUS
  928.        MINUS = NUMARG(.MINUS,1,.X)   -X       :(RETURN)
  929. MINUS.END
  930. *
  931.  DEFINE('MULT(X,Y)')      :(MULT.END)
  932. MULT
  933.        MULT =
  934. +         (NUMARG(.MULT,1,.X)  NUMARG(.MULT,2,.Y))
  935. +         X * Y           :(RETURN)
  936. MULT.END
  937. *
  938.  DEFINE('NCONC(LOL)LN,L')      :(NCONC.END)
  939. NCONC
  940.        NCONC = LISTARG(.NCONC,1,.LOL)   NIL
  941. NCONC1
  942.        NCONC = POP( .LOL)     :F(RETURN)
  943.        LISTARG( .NCONC, 1, .NCONC)
  944.        LN = ~NULL(LOL) LAST(NCONC)       :F(RETURN)
  945.        NULL(LN)      :S(NCONC1)
  946. NCONC2    L = POP( .LOL)
  947.        LISTARG( .NCONC, 1, .L)
  948.        (~NULL(L)   %RPLACD(LN,L))    :F(NCONC2)
  949.        LN = ~NULL(LOL) LAST(L)      :S(NCONC2)F(RETURN)
  950. NCONC.END
  951. *
  952.  DEFINE('NEG(X)')   :(NEG.END)
  953. NEG
  954.        (NUMARG(.NEG,1,.X) LT(X,0))
  955. +          :S(RETURN)F(FRETURN)
  956. NEG.END
  957. *
  958.  DEFINE('NEGP(X)')        :(NEGP.END)
  959. NEGP
  960.        NEGP = (NUMARG(.NEGP,1,.X) NEG(X))   T      :S(RETURN)
  961.        NEGP = NIL         :(RETURN)
  962. NEGP.END
  963. *
  964.  DEFINE('NTH(L,N)I')      :(NTH.END)
  965. NTH
  966.        (LISTARG(.NTH,1,.L) INTARG(.NTH,2,.N))
  967.        NTH = NEG(N) NTH(L,LENGTH(L) + N + 1)       :S(RETURN)
  968.        NTH = GT(N,LENGTH(L)) NIL    :S(RETURN)
  969.        NTH = L
  970.        I = 1
  971. NTH1   I = LT(I,N) I + 1       :F(RETURN)
  972.        NTH = CDR(NTH) :(NTH1)
  973. NTH.END
  974. *
  975.  DEFINE('NULLP(A)')       :(NULLP.END)
  976. NULLP
  977.        NULLP = (LISTARG(.NULLP,1,.A) NULL(A))  T       :S(RETURN)
  978.        NULLP = NIL        :(RETURN)
  979. NULLP.END
  980. *
  981.  DEFINE('NUMBERP(A)')     :(NUMBERP.END)
  982. NUMBERP
  983.        NUMBERP = NUMBER(A) T        :S(RETURN)
  984.        NUMBERP = NIL          :(RETURN)
  985. NUMBERP.END
  986. *
  987.  DEFINE('PLUS(L)')        :(PLUS.END)
  988. PLUS
  989.        PLUS = LISTARG(.PLUS,1,.L)
  990. +         ARITH(.ADD,L)        :(RETURN)
  991. PLUS.END
  992. *
  993.  DEFINE('PRELIST(L,N)')        :(PRELIST.END)
  994. PRELIST
  995.        (LISTARG(.PRELIST,1,.L) INTARG(.PRELIST,2,.N))
  996.        PRELIST = LREVERSE(SUFLIST(LREVERSE(L),-N))
  997. +          :(RETURN)
  998. PRELIST.END
  999. *
  1000.  DEFINE('PRINT.IN.FIELD(PIF...N.,PIF...S.)'
  1001. +      'PIF...C.,PIF...V.')
  1002.        :(PRINT.IN.FIELD.END)
  1003. PRINT.IN.FIELD
  1004.        PIF...N. = CONVERT( PIF...N., 'INTEGER' )
  1005. +         :F(PRINT.IN.FIELD.ERROR1)
  1006.        ATOM(PIF...S.)     :S(PRINT.IN.FIELD1)
  1007.        PIF...S. = UNREAD(PIF...S.)
  1008. +         :F(PRINT.IN.FIELD.ERROR2)
  1009. PRINT.IN.FIELD1
  1010.        PIF...S. = CONVERT( PIF...S., 'STRING' )
  1011. +         :F(PRINT.IN.FIELD.ERROR2)
  1012.        PIF...S.   POS(0)  (SPAN(' ')  | '')
  1013. +                 ANY('LCR') . PIF...C.   '.'   =
  1014. +                 :S(PRINT.IN.FIELD2)
  1015.        PRINT.IN.FIELD = DUPL( PIF...S., PIF...N. )
  1016. +         :(RETURN)
  1017. PRINT.IN.FIELD2
  1018.        PIF...S. = CONVERT( PIF...S., 'EXPRESSION' )
  1019. +         :F(PRINT.IN.FIELD.ERROR3)
  1020.        PIF...V. = EVAL( PIF...S. )
  1021. +          :F(PRINT.IN.FIELD.ERROR3)
  1022.        ATOM(PIF...V.)     :S(PRINT.IN.FIELD.BRANCH)
  1023.        PIF...V. = UNREAD(PIF...V.)
  1024. +         :F(PRINT.IN.FIELD.ERROR4)
  1025. PRINT.IN.FIELD.BRANCH
  1026.           :( $('PRINT.IN.FIELD.' PIF...C.) )
  1027. PRINT.IN.FIELD.L
  1028.        PRINT.IN.FIELD = GT(PIF...N.,SIZE(PIF...V.))
  1029. +         RPAD(PIF...V., PIF...N.)
  1030. +             :S(RETURN)F(PRINT.IN.FIELD3)
  1031. PRINT.IN.FIELD.R
  1032.        PRINT.IN.FIELD = GT(PIF...N.,SIZE(PIF...V.))
  1033. +         LPAD(PIF...V.,  PIF...N.)
  1034. +              :S(RETURN)F(PRINT.IN.FIELD3)
  1035. PRINT.IN.FIELD.C
  1036.        PRINT.IN.FIELD = GT(PIF...N.,SIZE(PIF...V.))
  1037. +         RPAD(LPAD(PIF...V.,
  1038. +          PIF...N. - FIX((PIF...N. - SIZE(PIF...V.)) / 2)),
  1039. +           PIF...N.)
  1040. +              :S(RETURN)
  1041. PRINT.IN.FIELD3
  1042.        PRINT.IN.FIELD = PIF...V.    :(RETURN)
  1043. PRINT.IN.FIELD.ERROR1
  1044.        |'In PRINT.IN.FIELD (%), the first argument is not an integer.'
  1045.        :(PRINT.IN.FIELD.ERRORDUMP)
  1046. PRINT.IN.FIELD.ERROR2
  1047.        |'In PRINT.IN.FIELD (%), the second argument has no'
  1048. +       ' string representation.'
  1049.        :(PRINT.IN.FIELD.ERRORDUMP)
  1050. PRINT.IN.FIELD.ERROR3
  1051.        |'In PRINT.IN.FIELD (%):  In the second argument,'
  1052.        |('the part after ' PIF...C.  '. could not be interpreted')
  1053.        |'as an expression.'
  1054.        :(PRINT.IN.FIELD.ERRORDUMP)
  1055. PRINT.IN.FIELD.ERROR4
  1056.        |'In PRINT.IN.FIELD (%):  In the second argument,'
  1057.        |('the part after ' PIF...C. '. could be interpreted')
  1058.        |'as an expression, but it did not evaluate to a legal value.'
  1059. PRINT.IN.FIELD.ERRORDUMP
  1060.        |''
  1061.        |'The values of the arguments and locals were:'
  1062.        |''
  1063.        |('PIF...N. = ' PIF...N.)
  1064.        |('PIF...S. = ' PIF...S.)
  1065.        |('PIF...V. = ' PIF...V.)
  1066.        |('PIF...C. = ' PIF...C.)
  1067.        TDUMP( 'PRINT.IN.FIELD' )
  1068.           :(END)
  1069. PRINT.IN.FIELD.END
  1070. *
  1071.  DEFINE('PUT(UNAME,PROP,VAL)PLT,LST,ELEM')   :(PUT.END)
  1072. PUT
  1073. *       UNAME = CONVERT(UNAME,'NAME')     :F(PUT.ERROR1)
  1074.        (IDENT(PROP) TDUMP(.PUT,2))
  1075.        ( ~ATOM(PROP) NULL(PROP) TDUMP(.PUT,2) )
  1076.        VAL = IDENT(VAL) NIL
  1077.        PLT = $'   PrOpErTy  LiSt  TaBlE   '
  1078.        PUT = ?( ~ATOM(VAL) NULL(VAL) )
  1079. +         (PROP ~ NIL) ~ NIL
  1080. +         :S(PUT1)
  1081.        PUT = (PROP ~ VAL ~ NIL) ~ NIL
  1082. PUT1
  1083.        LST = ITEM(PLT,UNAME)
  1084.        IDENT(LST)         :S(PUT4)
  1085.        ATOM(LST)          :S(PUT.ERROR2)
  1086.        NULL(LST)          :S(PUT4)
  1087. PUT2
  1088.        ELEM = POP( .LST)            :F(PUT3)
  1089.        ATOM(ELEM)         :S(PUT.ERROR2)
  1090.        PUT = ~EQUAL(CAR(ELEM),PROP)
  1091. +         ELEM ~ PUT          :(PUT2)
  1092. PUT3
  1093.        PUT = LREVERSE(PUT)
  1094. PUT4
  1095.        ITEM(PLT,UNAME) = PUT        :(RETURN)
  1096. PUT.ERROR1
  1097.        TDUMP(.PUT,1)
  1098. PUT.ERROR2
  1099.        |''
  1100.        |'Program error: In PUT,'
  1101.        |'a property list is not a list of lists.'
  1102.        |'The offending object is '
  1103.        |LST
  1104.        |''
  1105.        TDUMP(.PUT)
  1106. PUT.END
  1107. *
  1108.  DEFINE('PUTL(UNL,PROP,VAL)U...NAME.')      :(PUTL.END)
  1109. PUTL
  1110.        LISTARG( .PUTL, 1, .UNL)
  1111.        PUTL = NIL
  1112. PUTL1
  1113.        U...NAME. = POP( .UNL)      :F(RETURN)
  1114.        PUT(U...NAME.,PROP,VAL)       :(PUTL1)
  1115. PUTL.END
  1116. *
  1117.  DEFINE('PUTPROP(UNAME,VAL,PROP)PLT,LST,ELEM,FLAG')
  1118.        :(PUTPROP.END)
  1119. PUTPROP
  1120. *       UNAME = CONVERT(UNAME,'NAME')     :F(PUTPROP.ERROR1)
  1121.        (IDENT(PROP) TDUMP(.PUTPROP,2))
  1122.        ( ~ATOM(PROP) NULL(PROP) TDUMP(.PUTPROP,2))
  1123.        VAL = IDENT(VAL) NIL
  1124.        PUTPROP = NIL
  1125.        FLAG = ''
  1126.        PLT = $'   PrOpErTy  LiSt  TaBlE   '
  1127.        LST = ITEM(PLT,UNAME)
  1128.        IDENT(LST)         :S(PUTPROP2)
  1129.        ATOM(LST)          :S(PUTPROP.ERROR2)
  1130.        NULL(LST)          :S(PUTPROP2)
  1131. PUTPROP1
  1132.        ELEM = POP( .LST)             :F(PUTPROP2)
  1133.        ATOM(ELEM)         :S(PUTPROP.ERROR2)
  1134.        PUTPROP = ~EQUAL(CAR(ELEM),PROP)
  1135. +         ELEM ~ PUTPROP            :S(PUTPROP1)
  1136.        DIFFER(FLAG)            :S(PUTPROP1)
  1137.        FLAG = 1
  1138.        PUTPROP = ?( ~ATOM(VAL) NULL(VAL) )
  1139. +         ELEM ~ PUTPROP      :S(PUTPROP1)
  1140.        PUTPROP = (PROP ~ VAL ~ CDR(ELEM)) ~ PUTPROP
  1141. +         :(PUTPROP1)
  1142. PUTPROP2
  1143.        PUTPROP = DIFFER(FLAG)
  1144. +         LREVERSE(PUTPROP)         :S(PUTPROP4)
  1145.        PUTPROP = ?( ~ATOM(VAL) NULL(VAL) )
  1146. +         (PROP ~ NIL) ~ LREVERSE(PUTPROP)    :S(PUTPROP4)
  1147.        PUTPROP = (PROP ~ VAL ~ NIL) ~ LREVERSE(PUTPROP)
  1148. PUTPROP4
  1149.        ITEM(PLT,UNAME) = PUTPROP   :(RETURN)
  1150. PUTPROP.ERROR1
  1151.        TDUMP(.PUTPROP,1)
  1152. PUTPROP.ERROR2
  1153.        |''
  1154.        |'Program error:  In PUTPROP,'
  1155.        |'a property list is not a list of lists.'
  1156.        |'The offending object is '
  1157.        |LST
  1158.        |''
  1159.        TDUMP(.PUTPROP)
  1160. PUTPROP.END
  1161. *
  1162.  DEFINE('QUOTIENT(L)')        :(QUOTIENT.END)
  1163. QUOTIENT
  1164.        QUOTIENT = LISTARG(.QUOTIENT,1,.L)
  1165. +         ARITH(.DIV,L)       :(RETURN)
  1166. QUOTIENT.END
  1167. *
  1168.  DEFINE('RAC(L)')    :(RAC.END)
  1169. RAC
  1170.        RAC = LISTARG(.RAC,1,.L)
  1171. +         CAR(LREVERSE(L))          :(RETURN)
  1172. RAC.END
  1173. *
  1174.  DEFINE('RAD(D)')    :(RAD.END)
  1175. RAD
  1176.        RAD = NUMARG(.RAD,1,.D)  D * 0.017453292519943      :(RETURN)
  1177. RAD.END
  1178. *
  1179.  DEFINE('RAISE(X,Y)')    :(RAISE.END)
  1180. RAISE
  1181.        (NUMARG(.RAISE,1,.X) NUMARG(.RAISE,2,.Y))
  1182.        (LT(X,0) TDUMP(.RAISE,2))
  1183.        RAISE = EQ(X,0)   0.0       :S(RETURN)
  1184.        RAISE = X ** Y              :(RETURN)
  1185. RAISE.END
  1186. *
  1187.  DEFINE('RDC(L)')    :(RDC.END)
  1188. RDC
  1189.        LISTARG( .RDC, 1, .L)
  1190.        RDC = LREVERSE(CDR(LREVERSE(L)))       :(RETURN)
  1191. RDC.END
  1192. *
  1193.  DEFINE('READLIST(L)')        :(READLIST.END)
  1194. READLIST
  1195.        READLIST = LISTARG(.READLIST,1,.L)
  1196. +         READ(CONCAT(L))           :(RETURN)
  1197. READLIST.END
  1198. *
  1199.  DEFINE('REMOVE(L,OLD)PCA,PCD')     :(REMOVE.END)
  1200. REMOVE
  1201.        ATOM(L)       :F(REMOVE1)
  1202.        REMOVE = EQU(OLD,L) NIL      :S(RETURN)
  1203.        REMOVE = L    :(RETURN)
  1204. REMOVE1  REMOVE = NULL(L) NIL       :S(RETURN)
  1205.        REMOVE = EQUAL(L,OLD) NIL    :S(RETURN)
  1206.        PCA = REMOVE(CAR(L),OLD)
  1207.        PCD = REMOVE(CDR(L),OLD)
  1208.        REMOVE = (~ATOM(PCA) NULL(PCA))    PCD      :S(RETURN)
  1209.        REMOVE = PCA ~ PCD            :(RETURN)
  1210. REMOVE.END
  1211. *
  1212.  DEFINE('REMPROP(UNAME,PROP)PLT,LST,ELEM,NEW')    :(REMPROP.END)
  1213. REMPROP
  1214. *       UNAME = CONVERT(UNAME,'NAME')      :F(REMPROP.ERROR1)
  1215.        (IDENT(PROP) TDUMP(.REMPROP,2))
  1216.        ( ~ATOM(PROP) NULL(PROP) TDUMP(.REMPROP,2))
  1217.        PLT = $'   PrOpErTy  LiSt  TaBlE   '
  1218.        REMPROP = NIL
  1219.        LST = ITEM(PLT,UNAME)
  1220.        IDENT(LST)         :S(RETURN)
  1221.        ATOM(LST)          :S(REMPROP.ERROR2)
  1222.        NULL(LST)          :S(RETURN)
  1223.        NEW = NIL
  1224. REMPROP1
  1225.        ELEM = POP( .LST)             :F(REMPROP2)
  1226.        ATOM(ELEM)         :S(REMPROP.ERROR2)
  1227.        NEW = ~EQUAL(CAR(ELEM),PROP)
  1228. +         ELE ~ NEW            :S(REMPROP1)
  1229.        REMPROP = T        :(REMPROP1)
  1230. REMPROP2
  1231.        ITEM(PLT,UNAME) = LREVERSE(NEW)   :(RETURN)
  1232. REMPROP.ERROR1
  1233.        TDUMP(.REMPROP,1)
  1234. REMPROP.ERROR2
  1235.        |''
  1236.        |'Program error: In REMPROP,'
  1237.        |'a property list is not a list of lists.'
  1238.        |'The offending object is'
  1239.        |LST
  1240.        |''
  1241.        TDUMP(.REMPROP)
  1242. REMPROP.END
  1243. *
  1244.  DEFINE('ROUND(X)')      :(ROUND.END)
  1245. ROUND
  1246.        NUMARG( .ROUND, 1, .X)
  1247.        ROUND = LT(X,0) -FIX( -X + 0.5)   :S(RETURN)
  1248.        ROUND = FIX(X + 0.5)     :(RETURN)
  1249. ROUND.END
  1250. *
  1251.  DEFINE('RPLACA(L,A)')   :(RPLACA.END)
  1252. RPLACA
  1253.        CAR(L) = LISTARG(.RPLACA,1,.L)   A
  1254.        RPLACA = L    :(RETURN)
  1255. RPLACA.END
  1256. *
  1257.  DEFINE('RPLACD(L,A)')  :(RPLACD.END)
  1258. RPLACD
  1259.        CDR(L) = LISTARG(.RPLACD,1,.L)   A
  1260.        RPLACD = L    :(RETURN)
  1261. RPLACD.END
  1262. *
  1263.  DEFINE('RPLACN(L,N,S)I')      :(RPLACN.END)
  1264. RPLACN
  1265.        (LISTARG(.RPLACN,1,.L)  INTARG(.RPLACN,2,.N))
  1266.        RPLACN = NEG(N)
  1267. +         RPLACN(L,LENGTH(L) + N + 1,S)       :S(RETURN)
  1268.        RPLACN = GT(N,LENGTH(L))
  1269. +         NCONC( L ~ (S ~ NIL) ~ NIL)    :S(RETURN)
  1270.        RPLACN = ZERO(N)
  1271. +         S ~ L           :S(RETURN)
  1272.        I = 1
  1273. RPLACN1   I = LT(I,N) I + 1     :F(RPLACN2)
  1274.        L  = CDR(L)   :(RPLACN1)
  1275. RPLACN2   RPLACN = RPLACA(L,S)      :(RETURN)
  1276. RPLACN.END
  1277. *
  1278.  DEFINE('SET.(SET...N,V)')   :(SET..END)
  1279. SET.
  1280.        STRINGARG(.SET., 1, .SET...N)
  1281.        $SET...N = V
  1282.        SET. = V       :(RETURN)
  1283. SET..END
  1284. *
  1285.  DEFINE('SETL(LNV)')       :(SETL.END)
  1286. SETL
  1287.        SETL = LISTARG(.SETL,1,.LNV)    NIL
  1288.        EQ(REMDR(LENGTH(LNV),2),1)      :F(SETL1)
  1289.        TDUMP('SETL',1)
  1290. SETL1
  1291. +      SETL =  %LNV %CDR(LNV)
  1292. +         SET.(CAR(LNV),CADR(LNV)) ~ SETL      :F(SETL2)
  1293.        LNV = CDDR(LNV)    :(SETL1)
  1294. SETL2
  1295. +      SETL = LREVERSE(SETL)   :(RETURN)
  1296. SETL.END
  1297. *
  1298.  DEFINE('SIGN(X)')         :(SIGN.END)
  1299. SIGN
  1300.        NUMARG( .SIGN, 1, .X)
  1301.        SIGN = GT(X,0) 1  :S(RETURN)
  1302.        SIGN = LT(X,0) -1      :S(RETURN)
  1303.        SIGN = 0     :(RETURN)
  1304. SIGN.END
  1305. *
  1306.  DEFINE('SIN(A)K')             :(SIN.END)
  1307. SIN
  1308.        NUMARG( .SIN, 1, .A)
  1309.        SIN = LT(A) -SIN( -A)   :S(RETURN)
  1310.        SIN = LT(A, 2 * P...I.) SIN.(A)   :S(RETURN)
  1311.        K = FIX(A / (2 * P...I.))
  1312.        SIN = SIN.(A - K * 2 * P...I.)    :(RETURN)
  1313. SIN.
  1314.        A = DFLOAT(A)
  1315.        SIN. = EQ(27., 27. - 4 * A * A)  A
  1316. +         :S(RETURN)
  1317.        A = SIN.(A / 3)
  1318.        SIN. = A * (3 - 4  * A * A)             :(RETURN)
  1319. SIN.END
  1320. *
  1321.  DEFINE('SNOC(L,S)')       :(SNOC.END)
  1322. SNOC
  1323.        LISTARG( .SNOC, 1, .L)
  1324.        SNOC = APPEND(L ~ (S ~ NIL) ~ NIL)   :(RETURN)
  1325. SNOC.END
  1326. *
  1327.  DEFINE('SOME(FN,L)A,V')       :(SOME.END)
  1328. SOME
  1329.        SOME =
  1330. +         (STRINGARG(.SOME,1,.FN) LISTARG(.SOME,2,.L))
  1331. +         NIL
  1332. SOME1    A = POP( .L)  :F(RETURN)
  1333.        %APPLY(FN,A)       :F(SOME1)
  1334.        SOME = A ~ L       :(RETURN)
  1335. SOME.END
  1336. *
  1337.  DEFINE('SORT.(A,II,JJ,P)IU,IL,M,I,J,K,IJ,T,L,TT')
  1338.            :(SORT..END)
  1339. SORT.
  1340.        (DIFFER('ARRAY',DATATYPE(A)) TDUMP(.SORT., 1))
  1341.        (INTARG( .SORT., 2, .II)  INTARG( .SORT., 3, .JJ))
  1342.        P POS(0) ('LE' | 'GE' | 'LLE' | 'LGE') RPOS(0)
  1343. +          :S(SORT1)
  1344.        TDUMP( .SORT., 4)
  1345. SORT1
  1346.        IU = ARRAY(21)
  1347.        IL = COPY(IU)
  1348.        M = 1
  1349.        I = II
  1350.        J = JJ
  1351. SORT5  GE(I,J)       :S(SORT70)
  1352. SORT10    K = I
  1353.        IJ = CONVERT( (J + I) / 2, 'INTEGER' )
  1354.        T = A<IJ>
  1355.        SORT.LE(A<I>,T)    :S(SORT20)
  1356.        A<IJ> = A<I>
  1357.        A<I> = T
  1358.        T = A<IJ>
  1359. SORT20    L = J
  1360.        SORT.GE(A<J>,T)    :S(SORT40)
  1361.        A<IJ> = A<J>
  1362.        A<J> = T
  1363.        T = A<IJ>
  1364.        SORT.LE(A<I>,T)    :S(SORT40)
  1365.        A<IJ> = A<I>
  1366.        A<I> = T
  1367.        T = A<IJ>      :(SORT40)
  1368. SORT30    A<L> = A<K>
  1369.        A<K> = TT
  1370. SORT40     L = L - 1
  1371.        SORT.GT(A<L>,T)    :S(SORT40)
  1372.        TT = A<L>
  1373. SORT50    K = K + 1
  1374.        SORT.LT(A<K>,T)    :S(SORT50)
  1375.        LE(K,L)       :S(SORT30)
  1376.        LE( L - I, J - K)       :S(SORT60)
  1377.        IL<M> = I
  1378.        IU<M> = L
  1379.        I = K
  1380.        M = M + 1    :(SORT80)
  1381. SORT60   IL<M> = K
  1382.        IU<M> = J
  1383.        J = L
  1384.        M = M + 1    :(SORT80)
  1385. SORT70   M = M - 1
  1386.        SORT. = LE(M,0) A        :S(RETURN)
  1387.        I = IL<M>
  1388.        J = IU<M>
  1389. SORT80   GE( J - I, II)        :S(SORT10)
  1390.        EQ(I,II)      :S(SORT5)
  1391.        I = I - 1
  1392. SORT90    I = I + 1
  1393.        EQ(I,J)       :S(SORT70)
  1394.        T = A<I + 1>
  1395.        SORT.LE(A<I>,T)    :S(SORT90)
  1396.        K = I
  1397. SORT100  A<K + 1> = A<K>
  1398.        K = K - 1
  1399.        SORT.LT(T,A<K>)    :S(SORT100)
  1400.        A<K + 1> = T       :(SORT90)
  1401. *
  1402. SORT.LE  APPLY(P,X,Y)     :S(RETURN)F(FRETURN)
  1403. SORT.GE  APPLY(P,Y,X)     :S(RETURN)F(FRETURN)
  1404. SORT.LT  APPLY(P,Y,X)     :S(FRETURN)F(RETURN)
  1405. SORT.GT  APPLY(P,X,Y)     :S(FRETURN)F(RETURN)
  1406. SORT..END
  1407. *
  1408.  DEFINE('SQRT(Y)T')       :(SQRT.END)
  1409. SQRT
  1410.        NUMARG( .SQRT, 1, .Y)
  1411.        (LT(Y,0) TDUMP(.SQRT,1))
  1412.        SQRT = Y ** 0.5     :(RETURN)
  1413. SQRT.END
  1414. *
  1415.  DEFINE('SUB(X,Y)')     :(SUB.END)
  1416. SUB
  1417.        SUB =
  1418. +         (NUMARG(.SUB,1,.X) NUMARG(.SUB,2,.Y))
  1419. +         X - Y           :(RETURN)
  1420. SUB.END
  1421. *
  1422.  DEFINE('SUBSET(FN,L)A,V')   :(SUBSET.END)
  1423. SUBSET
  1424.        SUBSET =
  1425. +         (STRINGARG(.SUBSET,1,.FN) LISTARG(.SUBSET,2,.L))
  1426. +         NIL
  1427. SUBSET1   A = POP( .L) :F(SUBSET2)
  1428.        %APPLY(FN,A)       :F(SUBSET1)
  1429.        SUBSET = A ~ SUBSET         :(SUBSET1)
  1430. SUBSET2   SUBSET = LREVERSE(SUBSET)       :(RETURN)
  1431. SUBSET.END
  1432. *
  1433.  DEFINE('SUBST(L,OLD,NEW)PCA,PCD')      :(SUBST.END)
  1434. SUBST
  1435.        ATOM(L)       :F(SUBST1)
  1436.        SUBST = EQU(OLD,L) NEW       :S(RETURN)
  1437.        SUBST = L     :(RETURN)
  1438. SUBST1   SUBST = EQUAL(OLD,L) NEW        :S(RETURN)
  1439.        PCA = SUBST(CAR(L),OLD,NEW)
  1440.        PCD = SUBST(CDR(L),OLD,NEW)
  1441.        SUBST = PCA ~ PCD            :(RETURN)
  1442. SUBST.END
  1443. *
  1444.  DEFINE('SUB1(X)')       :(SUB1.END)
  1445. SUB1
  1446.        NUMARG( .SUB1, 1, .X)
  1447.        SUB1 = X - 1       :(RETURN)
  1448. SUB1.END
  1449. *
  1450.  DEFINE('SUFLIST(L,N)I')     :(SUFLIST.END)
  1451. SUFLIST
  1452.        (LISTARG(.SUFLIST,1,.L) INTARG(.SUFLIST,2,.N))
  1453.        SUFLIST = EQ(N,0)  L    :S(RETURN)
  1454.        SUFLIST = LT(N,0) SUFLIST(L,LENGTH(L) + N)
  1455. +         :S(RETURN)
  1456.        I = 0
  1457.        SUFLIST = L
  1458. SUFLIST1
  1459. +      I = ( LT(I,N) ?POP( .SUFLIST))    I + 1
  1460. +          :S(SUFLIST1)F(RETURN)
  1461. SUFLIST.END
  1462. *
  1463.  DEFINE('TAN(Z)')   :(TAN.END)
  1464. TAN
  1465.        NUMARG( .TAN, 1, .Z)
  1466.        TAN = SIN(Z)
  1467.        (GT(ABS(TAN),1) TDUMP( .TAN, 1))
  1468.        TAN = TAN / COS(Z,TAN)    :(RETURN)
  1469. TAN.END
  1470. *
  1471.   DEFINE('TDUMP(TDUMP...FN.,TDUMP...AN.)'
  1472. +      'TDUMP...I.,TDUMP...A.')      :(TDUMP.END)
  1473. TDUMP
  1474.        ||''
  1475.        |(6 % '* ' 'Terminal Error in ' TDUMP...FN.) |""
  1476.        |(12 % ' '   'Arguments') |""
  1477.        TDUMP...I. = 1
  1478. TDUMP1
  1479.        TDUMP...A. = ARG(TDUMP...FN.,TDUMP...I.)
  1480. +         :F(TDUMP2)
  1481.        $TDUMP...A. = ~ATOM($TDUMP...A.) UNREAD($TDUMP...A.)
  1482.        EQ(TDUMP...AN.,TDUMP...I.)   :F(TDUMP1.A)
  1483.        |(6 % '* ' TDUMP...A.  ' = ' $TDUMP...A.)
  1484.        TDUMP...I. = TDUMP...I. + 1        :(TDUMP1)
  1485. TDUMP1.A
  1486.        |(12 % ' ' TDUMP...A.  ' = ' $TDUMP...A.)
  1487.        TDUMP...I. = TDUMP...I. + 1
  1488. +         :(TDUMP1)
  1489. TDUMP2
  1490.        |''
  1491.        |(12 % ' '  'Locals') |""
  1492.        TDUMP...I. = 1
  1493. TDUMP3
  1494.        TDUMP...A. = LOCAL(TDUMP...FN.,TDUMP...I.)
  1495. +         :F(TDUMP4)
  1496.        $TDUMP...A. = ~ATOM($TDUMP...A.) UNREAD($TDUMP...A.)
  1497.        |(12 % ' ' TDUMP...A. ' = ' $TDUMP...A.)
  1498.        TDUMP...I.  = TDUMP...I. + 1        :(TDUMP3)
  1499. TDUMP4
  1500.        |''
  1501.        $TDUMP...FN. = ~ATOM($TDUMP...FN.) UNREAD($TDUMP...FN.)
  1502.        |(12 % ' ' TDUMP...FN. ' = ' $TDUMP...FN.) |""
  1503.        |(6 % '* '  'End of SNOLISPIST dump from ' TDUMP...FN.)
  1504.        |(6 % '  '  'You can get a SPITBOL dump:')
  1505.        |(6 % '  '  'Enter 0 for no dump, 1 for dump')
  1506.        &DUMP = MIN(1,MAX(0,CONVERT(IN(),'INTEGER')))
  1507.            :(END)
  1508. TDUMP.END
  1509. *
  1510.  DEFINE('TIMES(L)')       :(TIMES.END)
  1511. TIMES
  1512.        TIMES = LISTARG(.TIMES,1,.L) ARITH(.MULT,L)      :(RETURN)
  1513. TIMES.END
  1514. *
  1515.  DEFINE('UNION(L1,L2)A')      :(UNION.END)
  1516. UNION
  1517.        UNION =
  1518. +         (LISTARG(.UNION,1,.L1) LISTARG(.UNION,2,.L2))
  1519. +         NIL
  1520.        IDENT(L1,L2)       :S(UNION2)
  1521. UNION1    A = POP( .L1)       :F(UNION2)
  1522.        UNION = INSERT(A,UNION)   :(UNION1)
  1523. UNION2    A = POP( .L2)       :F(RETURN)
  1524.        UNION = INSERT(A,UNION)   :(UNION2)
  1525. UNION.END
  1526. *
  1527.  DEFINE('ZERO(X)')       :(ZERO.END)
  1528. ZERO
  1529.        (NUMARG(.ZERO,1,.X) EQ(X,0))      :S(RETURN)F(FRETURN)
  1530. ZERO.END
  1531. *
  1532.  DEFINE('ZEROP(A)')       :(ZEROP.END)
  1533. ZEROP
  1534.        ZEROP = (NUMARG(.ZEROP,1,.A) ZERO(A)) T     :S(RETURN)
  1535.        ZEROP = NIL        :(RETURN)
  1536. ZEROP.END
  1537.