home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / snobol / aisnobol / spitcore.spt < prev    next >
Text File  |  1987-10-12  |  24KB  |  924 lines
  1. * SPITCORE.SPT - SPITBOL-68K VERSION
  2. *
  3. * These are the core functions of the SNOLISPIST system.
  4. * Functions defined by DEXTERN are in SPITLIB.SPT (index in SPITLIB.IDX),
  5. * and are loaded dynamically when and if they are
  6. * called.
  7. *
  8. * Derived from "Artificial Intelligence Programming in SNOBOL4"
  9. *  by Michael Shafto.  Converted to SPITBOL-68K by Mark Emmer, Catspaw, Inc.
  10. *
  11. * Keyword section
  12. *
  13.   &ANCHOR    = 0
  14.   &CASE =    0
  15.   &DUMP =    0
  16.   &FTRACE    = 0
  17.   &STLIMIT = 2147483647
  18.   &TRACE = 0
  19.   &TRIM =  1
  20. *
  21. * Default I/O assignments
  22. *
  23.    INPUT(.INPUT.)
  24.    OUTPUT(.OUTPUT.)
  25. *
  26. * Defined datatypes and global variables
  27. *
  28.     DATA('CONS(CAR,CDR)')
  29.     NIL = CONS('','') ; T = CONS('T','T')
  30.     $'   PrOpErTy  LiSt  TaBlE   ' = TABLE()
  31. *
  32.  DEFINE('PRT.VIA.OUTPUT(S)')        :(PRT.VIA.OUTPUT.END)
  33. PRT.VIA.OUTPUT
  34.       ATOM(S)            :F(PRT.VIA.OUTPUT1)
  35.       S REM $ OUTPUT. $ PRT.VIA.OUTPUT       :(RETURN)
  36. PRT.VIA.OUTPUT1
  37.       UNREAD(S) REM $ OUTPUT. $ PRT.VIA.OUTPUT   :S(RETURN)
  38.       OUTPUT. = "Fatal error:  In PRT.VIA.OUTPUT, UNREAD failed."
  39.       OUTPUT. = " Argument datatype:  " DATATYPE(S)
  40.       :(END)
  41. PRT.VIA.OUTPUT.END
  42. *
  43.       OPSYN('|', .PRT.VIA.OUTPUT,  1)
  44.       OPSYN('PRINT','PRT.VIA.OUTPUT')
  45. *
  46. *
  47. * Functionals used to define functions
  48. *
  49.  DEFINE('DEXP(PROTO)NAME,ARGS')     :(DEXP.END)
  50. DEXP
  51.       PROTO POS(0) SPAN(' ') =
  52.       PROTO BREAK( "(" ) . NAME BAL . ARGS =
  53. +        :F(DEXP2)
  54.       NAME = IDENT(NAME,'LAMBDA') "LAMBDA..." &STCOUNT "."
  55. +        :F(DEXP1)
  56.       DEXP = NAME
  57. DEXP1 CODE( NAME " " NAME PROTO " :S(RETURN)F(FRETURN) ; " )
  58. +        :F(DEXP2)
  59.       DEFINE(  NAME ARGS )    :S(RETURN)
  60. DEXP2
  61.       PRINT(
  62. +         "Fatal error:  In DEXP, an illegal prototype "
  63. +         "or function name was detected.")
  64.       PRINT(
  65. +         "Prototype:  "   PROTO)
  66.                :(END)
  67. DEXP.END
  68. *
  69. *
  70. * Define external function
  71. * Modified from Gimpel to work with Macro Spitbol, which does not
  72. * handle statement label redefinitions properly (DEFINE must be
  73. * reexecuted).
  74. *
  75.  DEFINE('DEXTERN(PROTO,LBL)NAME')
  76.  DEFINE('LOADEX(LBL)LIB.FILE,PAT,X,CODE')
  77.     LOADEX...LIB. =  "spitlib.spt"
  78.     LOADEX...IDX. =  "spitlib.idx"
  79.     LOADEX...TBL. =  TABLE(51,25)
  80.     LOADEX...PROTO. = TABLE(51,25)
  81.     LOADEX...PAT. =  BREAK(',') . LOADEX...NAM. ',' REM . LOADEX...POS.
  82.     INPUT( .LIB.FILE, 15, LOADEX...IDX.)   :S(DEXTERN0)
  83.     TERMINAL =
  84. +        "Fatal error:  In DEXTERN, could not open library "
  85. +        "index: " LOADEX...IDX.                     :(END)
  86.           :(DEXTERN.END)
  87. *
  88. * Read index of functions into table from index file.
  89. *
  90. DEXTERN0
  91.     LIB.FILE LOADEX...PAT.                          :F(DEXTERN2)
  92.     LOADEX...TBL.<LOADEX...NAM.> = LOADEX...POS.    :(DEXTERN0)
  93. *
  94. DEXTERN2
  95.     ENDFILE(15)
  96.     INPUT( .LIB.FILE, 15, LOADEX...LIB.)   :S(DEXTERN.END)
  97.     TERMINAL =
  98. +        "Fatal error:  In DEXTERN, could not open library "
  99. +        "file: " LOADEX...LIB.                     :(END)
  100. *
  101. DEXTERN
  102.       PROTO IDENT(LBL) BREAK("(") . LBL
  103.  
  104.       CODE( LBL "  LOADEX('"  LBL  "') ; :(" LBL ")" )
  105. +         :F(DEXTERN1)
  106.       LOADEX...PROTO.<LBL> = PROTO
  107.       DEFINE(PROTO,LBL)       :S(RETURN)
  108. DEXTERN1
  109.       PRINT(
  110. +         "Fatal error:  In DEXTERN, an illegal prototype "
  111. +         "or function body was detected.")
  112.       PRINT(
  113. +         "Prototype:  "   PROTO)
  114.                :(END)
  115. *
  116. *
  117. * Load and code external function
  118. *
  119. LOADEX
  120.       LOADEX...POS. = LOADEX...TBL.<LBL>
  121.       IDENT(LOADEX...POS.)                      :S(LOADEX4)
  122.       SET(15, LOADEX...POS., 0)                 :F(LOADEX4)
  123. *
  124.       PAT = POS(0) LBL (" " | RPOS(0))
  125.       SETEXIT( .CONTINUE)
  126. LOADEX1
  127.       CODE = LIB.FILE    :F(LOADEX4)
  128.       CODE PAT      :F(LOADEX1)
  129.       PAT = POS(0) LBL '.END' (" " | RPOS(0))
  130. LOADEX2
  131.       X = LIB.FILE       :F(LOADEX4)
  132.       X PAT    :S(LOADEX3)
  133.       X POS(0) ANY('*-')      :S(LOADEX2)
  134.       X = ';' X
  135.       X POS(0) ';'  ANY('.+') = ' '
  136.       CODE = CODE X      :(LOADEX2)
  137. LOADEX3
  138.       CODE(CODE)         :F(LOADEX4)
  139. * Redefine for Macro Spitbol problem.  Clear table to reclaim space.
  140.       DEFINE(LOADEX...PROTO.<LBL>,LBL)       :F(LOADEX4)
  141.       LOADEX...PROTO.<LBL> = ""              :(RETURN)
  142. LOADEX4
  143.       PRINT(
  144. +       "Fatal error:  In LOADEX, a function was missing or uncodable.")
  145.              :(END)
  146. DEXTERN.END
  147. *
  148. *
  149. * Fatal-error message with optional dump
  150. *
  151.  DEXTERN('TDUMP(TDUMP...FN.,TDUMP...AN.)'
  152. +      'TDUMP...I.,TDUMP...A.')
  153. *
  154. * Argument checking functions
  155. *
  156.  DEFINE('LISTARG(FNAME,ANUM,ARG...NAME.)')
  157.             :(LISTARG.END)
  158. LISTARG
  159.        IDENT(DATATYPE( $ARG...NAME.),  'CONS')     :S(RETURN)
  160.        |''
  161.        |('Argument number ' ANUM " to " FNAME " (" ARG...NAME. ')')
  162.        |("has illegal datatype " DATATYPE( $ARG...NAME.) '.')
  163.        |('Datatype CONS was expected.')
  164.        TDUMP( FNAME, ANUM)
  165. LISTARG.END
  166. *
  167.  DEFINE('NUMARG(FNAME,ANUM,ARG...NAME.)')  :(NUMARG.END)
  168. NUMARG
  169.      NUMBER( $ARG...NAME.)        :S(RETURN)
  170.      |''
  171.      |("Argument number " ANUM " to " FNAME " (" ARG...NAME. ')')
  172.      |("has illegal value " $ARG...NAME. '.')
  173.      |("A NUMERIC value was expected.")
  174.      TDUMP( FNAME, ANUM)
  175. NUMARG.END
  176. *
  177.  DEFINE('INTARG(FNAME,ANUM,ARG...NAME.)')    :(INTARG.END)
  178. INTARG
  179.      INTEGER( $ARG...NAME.)   :S(RETURN)
  180.      |''
  181.      |("Argument number " ANUM " to " FNAME " (" ARG...NAME.  ')')
  182.      |("has illegal value " $ARG...NAME. '.')
  183.      |("An INTEGER was expected.")
  184.      TDUMP( FNAME, ANUM)
  185. INTARG.END
  186. *
  187.  DEFINE('STRINGARG(FNAME,ANUM,ARG...NAME.)')       :(STRINGARG.END)
  188. STRINGARG
  189.       DATATYPE( $ARG...NAME.)
  190. +         POS(0) ('STRING' | 'NAME') RPOS(0)
  191. +         :S(RETURN)
  192.       |''
  193.       |("Argument number " ANUM " to " FNAME " (" ARG...NAME.  ')')
  194.       |("has illegal datatype " DATATYPE( $ARG...NAME.) '.')
  195.       |("Datatype STRING or NAME was expected.")
  196.       TDUMP( FNAME, ANUM)
  197. STRINGARG.END
  198. *
  199. *
  200. * CAR/CDR compounds
  201. *
  202.      DEXTERN( 'CAAR(L)' )
  203.      DEXTERN( 'CADR(L)' )
  204.      DEXTERN( 'CDAR(L)' )
  205.      DEXTERN( 'CDDR(L)' )
  206.      DEXTERN( 'CAAAR(L)' )
  207.      DEXTERN( 'CAADR(L)' )
  208.      DEXTERN( 'CADAR(L)' )
  209.      DEXTERN( 'CDAAR(L)' )
  210.      DEXTERN( 'CADDR(L)' )
  211.      DEXTERN( 'CDADR(L)' )
  212.      DEXTERN( 'CDDAR(L)' )
  213.      DEXTERN( 'CDDDR(L)' )
  214.      DEXTERN( 'CAAAAR(L)' )
  215.      DEXTERN( 'CAAADR(L)' )
  216.      DEXTERN( 'CAADAR(L)' )
  217.      DEXTERN( 'CADAAR(L)' )
  218.      DEXTERN( 'CDAAAR(L)' )
  219.      DEXTERN( 'CAADDR(L)' )
  220.      DEXTERN( 'CADADR(L)' )
  221.      DEXTERN( 'CDAADR(L)' )
  222.      DEXTERN( 'CADDAR(L)' )
  223.      DEXTERN( 'CDADAR(L)' )
  224.      DEXTERN( 'CDDAAR(L)' )
  225.      DEXTERN( 'CADDDR(L)' )
  226.      DEXTERN( 'CDADDR(L)' )
  227.      DEXTERN( 'CDDADR(L)' )
  228.      DEXTERN( 'CDDDAR(L)' )
  229.      DEXTERN( 'CDDDDR(L)' )
  230. *
  231. * Predicate:  Is A = NIL?
  232. *
  233.  DEXP('NULL(A) = '
  234. +     '?(LISTARG( .NULL, 1, .A) '
  235. +     'IDENT(CAR(A)) IDENT(CDR(A)))')
  236.      OPSYN(.NOT,.NULL)
  237. *
  238. * Make new CONS cell
  239. *
  240.  DEXP('LIST(S1,S2) = CONS(S1,S2)')
  241.      OPSYN("~",.LIST,2)
  242. *
  243. * Function of zero arguments which returns a unique name
  244. *
  245.  DEFINE('GENSYM()')      :(GENSYM.END)
  246. GENSYM
  247. +      GENSYM = 'GSYM' &STCOUNT
  248.        IDENT($GENSYM)     :S(RETURN)F(GENSYM)
  249. GENSYM.END
  250.      OPSYN( .NEWSYM, .GENSYM)
  251. -EJECT
  252. *
  253. * I/O functions
  254. *
  255. *
  256. * Formatted output
  257. *
  258.  DEFINE('PRINT.IN.FIELD(PIF...N.,PIF...S.)'
  259. +      'PIF...C.,PIF...V.')
  260.        :(PRINT.IN.FIELD.END)
  261. PRINT.IN.FIELD
  262.        PIF...N. = CONVERT( PIF...N., 'INTEGER' )
  263. +         :F(PRINT.IN.FIELD.ERROR1)
  264.        ATOM(PIF...S.)     :S(PRINT.IN.FIELD1)
  265.        PIF...S. = UNREAD(PIF...S.)
  266. +         :F(PRINT.IN.FIELD.ERROR2)
  267. PRINT.IN.FIELD1
  268.        PIF...S. = CONVERT( PIF...S., 'STRING' )
  269. +         :F(PRINT.IN.FIELD.ERROR2)
  270.        PIF...S.   POS(0)  (SPAN(' ')  | '')
  271. +                 ANY('LCR') . PIF...C.   '.'   =
  272. +                 :S(PRINT.IN.FIELD2)
  273.        PRINT.IN.FIELD = DUPL( PIF...S., PIF...N. )
  274. +         :(RETURN)
  275. PRINT.IN.FIELD2
  276.        PIF...S. = CONVERT( PIF...S., 'EXPRESSION' )
  277. +         :F(PRINT.IN.FIELD.ERROR3)
  278.        PIF...V. = EVAL( PIF...S. )
  279. +          :F(PRINT.IN.FIELD.ERROR3)
  280.        ATOM(PIF...V.)     :S(PRINT.IN.FIELD.BRANCH)
  281.        PIF...V. = UNREAD(PIF...V.)
  282. +         :F(PRINT.IN.FIELD.ERROR4)
  283. PRINT.IN.FIELD.BRANCH
  284.           :( $('PRINT.IN.FIELD.' PIF...C.) )
  285. PRINT.IN.FIELD.L
  286.        PRINT.IN.FIELD = GT(PIF...N.,SIZE(PIF...V.))
  287. +         RPAD(PIF...V., PIF...N.)
  288. +             :S(RETURN)F(PRINT.IN.FIELD3)
  289. PRINT.IN.FIELD.R
  290.        PRINT.IN.FIELD = GT(PIF...N.,SIZE(PIF...V.))
  291. +         LPAD(PIF...V.,  PIF...N.)
  292. +              :S(RETURN)F(PRINT.IN.FIELD3)
  293. PRINT.IN.FIELD.C
  294.        PRINT.IN.FIELD = GT(PIF...N.,SIZE(PIF...V.))
  295. +         RPAD(LPAD(PIF...V.,
  296. +          PIF...N. - FIX((PIF...N. - SIZE(PIF...V.)) / 2)),
  297. +           PIF...N.)
  298. +              :S(RETURN)
  299. PRINT.IN.FIELD3
  300.        PRINT.IN.FIELD = PIF...V.    :(RETURN)
  301. PRINT.IN.FIELD.ERROR1
  302.        |'In PRINT.IN.FIELD (%), the first argument is not an integer.'
  303.        :(PRINT.IN.FIELD.ERRORDUMP)
  304. PRINT.IN.FIELD.ERROR2
  305.        |'In PRINT.IN.FIELD (%), the second argument has no'
  306. +       ' string representation.'
  307.        :(PRINT.IN.FIELD.ERRORDUMP)
  308. PRINT.IN.FIELD.ERROR3
  309.        |'In PRINT.IN.FIELD (%):  In the second argument,'
  310.        |('the part after ' PIF...C.  '. could not be interpreted')
  311.        |'as an expression.'
  312.        :(PRINT.IN.FIELD.ERRORDUMP)
  313. PRINT.IN.FIELD.ERROR4
  314.        |'In PRINT.IN.FIELD (%):  In the second argument,'
  315.        |('the part after ' PIF...C. '. could be interpreted')
  316.        |'as an expression, but it did not evaluate to a legal value.'
  317. PRINT.IN.FIELD.ERRORDUMP
  318.        |''
  319.        |'The values of the arguments and locals were:'
  320.        |''
  321.        |('PIF...N. = ' PIF...N.)
  322.        |('PIF...S. = ' PIF...S.)
  323.        |('PIF...V. = ' PIF...V.)
  324.        |('PIF...C. = ' PIF...C.)
  325.        TDUMP( 'PRINT.IN.FIELD' )
  326.           :(END)
  327. PRINT.IN.FIELD.END
  328.       OPSYN('%',  .PRINT.IN.FIELD, 2)
  329. *
  330. * Standard Input
  331. *
  332.  DEFINE('IN(IN...N)')      :(IN.END)
  333. IN    IN...N = IDENT(IN...N)  .IN
  334.       STRINGARG(  .IN, 1,  .IN...N)
  335.       SETEXIT( .CONTINUE)
  336.       $IN...N = INPUT.   :F(FRETURN)
  337.       IN = DIFFER(IN...N,  .IN) $IN...N
  338.           :(RETURN)
  339. IN.END
  340.  
  341. *
  342. * Interactive tracing
  343. *
  344.  DEXTERN('LTRACE(PARAM,L)F,TFNAME')
  345. -EJECT
  346. *
  347. * General-purpose and datatype predicates
  348. *
  349. *
  350.  DEXP('FAIL.IF.NIL(A) = '
  351. +     '?(LISTARG( .FAIL.IF.NIL, 1, .A)  ~NULL(A))   A')
  352.       OPSYN('/',  .FAIL.IF.NIL, 1)
  353. *
  354.  DEXP('FAIL.IF.NIL.ELSE.SUCCEED(X) = '
  355. +     '?(LISTARG( .FAIL.IF.NIL.ELSE.SUCCEED, 1, .X) /X)')
  356.       OPSYN("%",  .FAIL.IF.NIL.ELSE.SUCCEED, 1)
  357. *
  358. *
  359.  DEFINE('NULLP(A)')       :(NULLP.END)
  360. NULLP
  361.        NULLP = (LISTARG(.NULLP,1,.A) NULL(A))  T       :S(RETURN)
  362.        NULLP = NIL        :(RETURN)
  363. NULLP.END
  364.       OPSYN(.NOTP,.NULLP)
  365. *
  366.  DEXP('VALUE(A) = $A')
  367. *
  368.  DEXP('ATOM(A) = DIFFER(DATATYPE(A),"CONS")')
  369. *
  370.  DEXTERN('ATOMP(A)')
  371. *
  372.  DEXP('NUMBER(X) = ?CONVERT(X,"NUMERIC")')
  373. *
  374.  DEXTERN('NUMBERP(A)')
  375. *
  376.  DEXTERN('EQU(A1,A2)')
  377. *
  378.  DEXTERN('EQP(A1,A2)')
  379. *
  380.  DEXTERN('EQUAL(X,Y)')
  381. *
  382.  DEXTERN('EQUALP(A1,A2)')
  383. *
  384. -EJECT
  385. *      Numeric predicates:
  386. *
  387. *
  388.  DEXTERN('NEG(X)')
  389. *
  390.  DEXTERN('NEGP(X)')
  391. *
  392.  DEXTERN('ZERO(X)')
  393. *
  394.  DEXTERN('ZEROP(X)')
  395. *
  396.  DEXTERN('LESS(L)A,B')
  397. *
  398.  DEXTERN('LESSP(L)')
  399. *
  400.  DEXTERN('GREATER(L)A,B')
  401. *
  402.  DEXTERN('GREATERP(L)')
  403. *
  404. * Numeric functions
  405. *
  406. *      Single argument:
  407. *
  408.  DEXTERN('ABS(X)')
  409. *
  410.  DEXTERN('SIGN(X)')
  411. *
  412.  DEXTERN('ADD1(X)')
  413. *
  414.  DEXTERN('SUB1(X)')
  415. *
  416.  DEXTERN('FLOAT(N)')
  417. *
  418.  DEXTERN('DFLOAT(N)')
  419. *
  420.  DEXTERN('FIX(X)')
  421. *
  422.  DEXTERN('MINUS(X)')
  423. *
  424.  DEXTERN('ROUND(X)')
  425. *
  426. *      Binary:
  427. *
  428.  DEXTERN('ADD(X,Y)')
  429. *
  430.  DEXTERN('SUB(X,Y)')
  431. *
  432.  DEXTERN('MULT(X,Y)')
  433. *
  434.  DEXTERN('DIV(X,Y)')
  435. *
  436.  DEXTERN('MAX(X,Y)')
  437. *
  438.  DEXTERN('MIN(X,Y)')
  439. *
  440.      OPSYN(.REMAINDER, .REMDR)
  441. *
  442. *      List argument:
  443. *
  444.  DEXTERN('PLUS(L)')
  445. *
  446.  DEXTERN('DIFFERENCE(L)')
  447. *
  448.  DEXTERN('TIMES(L)')
  449. *
  450.  DEXTERN('QUOTIENT(L)')
  451. *
  452.  DEXTERN('ARITH(OP,ALIST)A')
  453. *
  454. * List functions
  455. *
  456. *      Composition:
  457. *      CONS operates via datatype definition
  458. *
  459. *
  460.  DEXTERN('APPEND(LOL)L,A')
  461. *
  462.  DEFINE('EXCLUDE(L,XCL)A')   :(EXCLUDE.END)
  463. EXCLUDE
  464.        EXCLUDE =
  465. +        (LISTARG(.EXCLUDE,1,.L) LISTARG(.EXCLUDE,2,.XCL))
  466. +        NIL
  467. EXCLUDE1      A = POP( .L)  :F(EXCLUDE2)
  468.        EXCLUDE  = ~MEMQ(A,XCL) INSERT(A,EXCLUDE)     :(EXCLUDE1)
  469. EXCLUDE2      EXCLUDE = LREVERSE(EXCLUDE)     :(RETURN)
  470. EXCLUDE.END
  471. *
  472.  DEXTERN('INSERT(S,L)')
  473. *
  474.  DEXTERN('INTERSECT(L1,L2)L,A')
  475. *
  476.  DEXTERN('LCOPY(L)CA,CD')
  477. *
  478.  DEXTERN('NCONC(LOL)LN,L')
  479. *
  480.  DEXTERN('PUT(UNAME,PROP,VAL)PLT,LST,ELEM')
  481. *
  482.  DEXTERN('REMPROP(UNAME,PROP)PLT,LST,ELEM,NEW')
  483. *
  484.  DEXTERN('PUTPROP(UNAME,VAL,PROP)PLT,LST,ELEM,FLAG')
  485. *
  486.  DEXTERN('ADDPROP(UNAME,VAL,PROP)PLT,LST,ELEM,FLAG')
  487. *
  488.  DEXTERN('GETPROP(UNAME,PROP)PLT,LST,ELEM,FLAG,NEW')
  489. *
  490.  DEXTERN('DEFPROP(A1,EXP,A2)')
  491. *
  492.  DEXTERN('PUTL(UNL,PROP,VAL)U...NAME.')
  493. *
  494.  DEXTERN('LREVERSE(LST)')
  495. *
  496.  DEXTERN('RPLACA(L,A)')
  497. *
  498.  DEXTERN('RPLACD(L,A)')
  499. *
  500.  DEXTERN('RPLACN(L,N,S)I')
  501. *
  502.  DEXTERN('SNOC(L,S)')
  503. *
  504.  DEXTERN('SUBST(L,OLD,NEW)PCA,PCD')
  505. *
  506.  DEXTERN('UNION(L1,L2)A')
  507. *
  508.  DEXTERN('EXPLODE(A)CH')
  509. *
  510.  DEXTERN('READLIST(L)S')
  511. *
  512. *      Decomposition:
  513. *
  514.  DEXTERN('LAST(L)')
  515. *
  516.  DEXTERN('NTH(L,N)I')
  517. *
  518.  DEXTERN('PRELIST(L,N)')
  519. *
  520.  DEXTERN('RAC(L)')
  521. *
  522.  DEXTERN('RDC(L)')
  523. *
  524.  DEXTERN('REMOVE(L,OLD)PCA,PCD')
  525. *
  526.  DEXTERN('SUFLIST(L,N)I')
  527. *
  528. *
  529. * Pop stack (argument is NAME)
  530. *
  531.  DEFINE('UNCONS(UNCONS...N)')      :(UNCONS.END)
  532. UNCONS
  533.        (ATOM( $UNCONS...N) TDUMP(.UNCONS,1))
  534.        NULL( $UNCONS...N)      :S(FRETURN)
  535.        (ATOM(CDR($UNCONS...N)) TDUMP(.UNCONS,1))
  536.        UNCONS = CAR( $UNCONS...N)
  537.        $UNCONS...N = CDR( $UNCONS...N)   :(RETURN)
  538. UNCONS.END    OPSYN(.POP, .UNCONS)
  539. *
  540. *      Search:
  541. *
  542.  DEXTERN('ASSOC(TG,L)C')
  543. *
  544.  DEXTERN('ASSOCL(LTG,L)A')
  545. *
  546.  DEXTERN('FIND(TG,L)')
  547. *
  548.  DEXTERN('GET(UNAME,PROP)PLT,LST,ELEM')
  549. *
  550.  DEXTERN('GETL(UNAME,LPROP)PLT,LST,ELEM')
  551. *
  552.  DEXTERN('MEMBER(A,MBR)')
  553. *
  554.  DEXTERN('MEMQ(A,L)')
  555.  
  556. *
  557. *      Miscellaneous:
  558. *
  559.  DEXTERN('LENGTH(L)')
  560. *
  561.  DEXTERN('SET.(SET...N,V)')
  562. *
  563.  DEXTERN('SETL(LNV)')
  564. *
  565.  DEXTERN('EVALCODE(S)')
  566.  
  567. *
  568. * READ function, Version 2
  569. *
  570. *     Converts string to list.
  571. *
  572. *
  573. * The FASTBAL function is from
  574. *     Gimpel,  J. F.  Algorithms in SNOBOL4,  Chapter 9.
  575. *
  576.  DEFINE('FASTBAL(PARENS,QTS,S)NAME,IBAL,SPCHARS,ELEM'
  577. +       ',LPS,Q,LP,RP')       :(FASTBAL.END)
  578. FASTBAL NAME  = 'FASTBAL...' &STCOUNT '.'
  579.        IBAL = CONVERT(NAME,'EXPRESSION')
  580.        IBAL = DIFFER(S,'') FASTBAL(PARENS,QTS,'')
  581.        SPCHARS = PARENS QTS S
  582.        ELEM = NOTANY(PARENS QTS) BREAK(SPCHARS)
  583. FASTBAL1      QTS LEN(1) . Q =     :F(FASTBAL2)
  584.        ELEM = Q BREAK(Q) Q | ELEM  :(FASTBAL1)
  585. FASTBAL2      PARENS LEN(1) . LP RTAB(1) . PARENS LEN(1) . RP
  586. +     :F(FASTBAL3)
  587.        ELEM = LP IBAL RP | ELEM    :(FASTBAL2)
  588. FASTBAL3      FASTBAL =  BREAK(SPCHARS) ARBNO(ELEM)
  589.        $NAME = FASTBAL    :(RETURN)
  590. FASTBAL.END
  591.  
  592.  
  593. *
  594. * Patterns used by more than one subroutine of READ
  595. *
  596.  READ...SPB.    = SPAN(" ")
  597.  READ...SPBN.   = SPAN(" ") | ''
  598.  READ...RF. = POS(0) READ...SPBN. "(" READ...SPBN. FENCE
  599.  READ...RF2. = POS(0) READ...SPBN. FENCE
  600.  READ...RE. = READ...SPBN. ')' READ...SPBN. RPOS(0)
  601.  READ...BALQ. =
  602. +     FASTBAL( '(<>)', '"' "'", ' )' ) $ READ...BQ.TEMP
  603. +     *DIFFER(READ...BQ.TEMP)
  604.  
  605.  
  606. *
  607. * Recognize and read a T or NIL
  608. *
  609. *     Note: T and NIL are also specially recognized by
  610. *           READ.DOTPAIR
  611. *
  612.  DEFINE('READ.NIL(S)')
  613.      READ...NILPAT. = READ...RF. READ...SPBN. READ...RE.
  614.        :(READ.NIL.END)
  615. READ.NIL
  616.        READ.NIL = IDENT(S,'T') T    :S(RETURN)
  617.        READ.NIL = IDENT(S,'NIL') NIL     :S(RETURN)
  618.        S READ...NILPAT.   :F(FRETURN)
  619.        READ.NIL = NIL     :(RETURN)
  620. READ.NIL.END
  621.  
  622. *
  623. * Recognize and read a dotted pair
  624. *
  625.  DEFINE('READ.DOTPAIR(S)PCAR,PCDR')
  626.        READ...SPD. = BREAKX(' ') ' . '
  627.        READ...SPBDSPB. = READ...SPB. '.' READ...SPB.
  628.        :(READ.DOTPAIR.END)
  629. *
  630. READ.DOTPAIR
  631.        S READ...SPD.      :F(FRETURN)
  632.        S READ...RF. READ...BALQ. . PCAR
  633. +         READ...SPBDSPB.  =    :F(FRETURN)
  634.        S  READ...RF2. READ...BALQ. . PCDR
  635. +         READ...RE.      :F(READ.DOTPAIR1)
  636.        PCAR = READ(PCAR)  ; PCDR = READ(PCDR)
  637.        READ.DOTPAIR = IDENT(PCAR) IDENT(PCDR)
  638. +         NIL  :S(RETURN)
  639.        READ.DOTPAIR = IDENT(PCAR,'T') IDENT(PCDR,'T')
  640. +         T     :S(RETURN)
  641.        READ.DOTPAIR = PCAR ~ PCDR  :(RETURN)
  642. *
  643. READ.DOTPAIR1
  644.        TDUMP('READ.DOTPAIR',1)
  645. READ.DOTPAIR.END
  646.  
  647.  
  648. *
  649. * Recognize and read a list of one element.
  650. *      The element may be a single atom, a single list,
  651. *         or a single dotted pair.
  652. *
  653.  DEFINE('READ.SINGLETON(S)PCAR')
  654.       READ...RJ. = READ...RF.   READ...BALQ. READ...SPB. NOTANY( ')' )
  655.          :(READ.SINGLETON.END)
  656. READ.SINGLETON
  657.        S READ...RJ.       :S(FRETURN)
  658.        S READ...RF. READ...BALQ. . PCAR READ...RE.
  659. +      :F(FRETURN)
  660.        READ.SINGLETON = READ(PCAR) ~ NIL       :(RETURN)
  661. READ.SINGLETON.END
  662.  
  663.  
  664. *
  665. * Recognize and read a "regular" list.
  666. *      This means a list of two or more elements
  667. *         (not a dotted pair) such that the final
  668. *         top-level element of the list is NIL.
  669. *
  670.  DEFINE('READ.REGULAR(S)S2,PCAR,RLIST')
  671.        :(READ.REGULAR.END)
  672. READ.REGULAR
  673.        S READ...RF. READ...BALQ. . PCAR READ...SPB. =
  674. +         :F(FRETURN)
  675.        RLIST = PCAR ~ NIL
  676. READ.REGULAR1
  677.        S READ...RF2. READ...BALQ. . PCAR READ...SPB.
  678. +        (NOTANY(')') REM) . S2   =   S2
  679. +        :F(READ.REGULAR2)
  680.        RLIST = PCAR ~ RLIST    :(READ.REGULAR1)
  681. READ.REGULAR2
  682.        S READ...RF2. READ...BALQ. . PCAR READ...RE.
  683. +        :F(READ.REGULAR3)
  684.        RLIST = PCAR ~ RLIST
  685.        READ.REGULAR = MAPCARV( .READ, RLIST)       :(RETURN)
  686. *
  687. READ.REGULAR3
  688.        TDUMP('READ.REGULAR',1)
  689. READ.REGULAR.END
  690.  
  691.  
  692. *
  693. * Read an atom
  694. *     "" and '' translate to the null string.
  695. *     An error results (FRETURN) if
  696. *        a)  the beginning of S looks like the
  697. *            beginning of a list;
  698. *        b)  the end of S looks like the end of a list;
  699. *        c)  S is the null string.
  700. *
  701.  DEFINE('READ.ATOM(S)N,PRE')
  702.      READ...RE2. = BREAKX( ')' )   READ...RE.
  703.      READ...EV. = "\"
  704.             :(READ.ATOM.END)
  705. READ.ATOM
  706.        (DIFFER(S,'""') DIFFER(S,"''"))   :F(RETURN)
  707.        S READ...RF.       :S(FRETURN)
  708.        S READ...RE2.      :S(FRETURN)
  709.        READ.ATOM = DIFFER(S) S      :F(FRETURN)
  710.        READ.ATOM SPAN(READ...EV.) . PRE =     :F(RETURN)
  711.        N = SIZE(PRE)
  712. READ.ATOM1
  713.        (GT(N) ?SET.( .N, N - 1)
  714. +      ?SET.( 'READ.ATOM', EVAL( READ.ATOM)) )
  715. +        :S(READ.ATOM1)F(RETURN)
  716. READ.ATOM.END
  717.  
  718.  
  719. *
  720. * This is the main string-to-list conversion routine.
  721. *
  722.   DEFINE('READ(S)')      :(READ.END)
  723. READ  TRIM(S)
  724. +        POS(0) READ...SPBN. REM $ S
  725.        READ = READ.NIL(S)           :S(RETURN)
  726.        READ = READ.DOTPAIR(S)       :S(RETURN)
  727.        READ = READ.SINGLETON(S)     :S(RETURN)
  728.        READ = READ.REGULAR(S)       :S(RETURN)
  729.        READ = READ.ATOM(S)          :S(RETURN)
  730. *
  731.        TDUMP('READ',1)
  732. READ.END
  733. +     OPSYN('#', .READ, 1)
  734. *
  735. * List to string conversion routine.
  736. *
  737. *     CONCAT takes a list of strings and concatenates
  738. *        them into one long string.  PAD is inserted
  739. *        after each substring except the last.  QT can
  740. *        be omitted (treated as the null string); if present
  741. *        it is appended to front and end of each substring.
  742. *
  743.       DEFINE('CONCAT(L,PAD,QT)')     :(CONCAT.END)
  744. CONCAT
  745.        LISTARG( .CONCAT, 1, .L)
  746.        STRINGARG( .CONCAT, 2, .PAD)
  747.        STRINGARG( .CONCAT, 3, .QT)
  748.        CONCAT =
  749. +      CONCAT QT POP( .L) QT PAD    :S(CONCAT)
  750.        CONCAT RTAB(SIZE(PAD)) . CONCAT     :(RETURN)
  751. CONCAT.END
  752. *
  753. * Convert NIL or T
  754. *
  755.       DEFINE('UNREAD.NIL(L)')      :(UNREAD.NIL.END)
  756. UNREAD.NIL
  757.        ATOM(L)       :S(FRETURN)
  758.        UNREAD.NIL = NULL(L) 'NIL'   :S(RETURN)
  759.        UNREAD.NIL = IDENT(L,T) 'T'       :S(RETURN)F(FRETURN)
  760. UNREAD.NIL.END
  761. *
  762. * Convert dotted pair
  763. *
  764.  DEFINE('UNREAD.DOTPAIR(L)PCAR,PCDR') :(UNREAD.DOTPAIR.END)
  765. UNREAD.DOTPAIR
  766.        (~ATOM(L) ATOM( CDR(L)))     :F(FRETURN)
  767.        UNREAD.DOTPAIR =
  768. +        IDENT(CAR(L)) IDENT(CDR(L)) 'NIL'   :S(RETURN)
  769.        UNREAD.DOTPAIR =
  770. +        IDENT(CAR(L),'T') IDENT(CDR(L),'T') 'T'       :S(RETURN)
  771.        PCAR = UNREAD(CAR(L)) ; PCDR = UNREAD(CDR(L))
  772.        UNREAD.DOTPAIR =
  773. +        '(' PCAR ' . ' PCDR ')'   :(RETURN)
  774. UNREAD.DOTPAIR.END
  775. *
  776. * Convert a list of one element
  777. *
  778.  DEXP('UNREAD.SINGLETON(L) = '
  779. +     '(~ATOM(L) NULL( CDR(L))) '
  780. +     '"(" UNREAD( CAR(L)) ")"' )
  781. *
  782. * Convert a regular, multi-element list
  783. *
  784.  DEXP('UNREAD.REGULAR(L) = '
  785. +     '~ATOM(L) '
  786. +     '"(" CONCAT(MAPCAR( .UNREAD,L), " ") ")"' )
  787. *
  788. * Convert an atom
  789. *     Null string ==> ""
  790. *     If the atom contains internal blanks,
  791. *        it will be enclosed in double quotes,
  792. *        unless it is already enclosed in single or
  793. *        double quotes.
  794. *
  795.  DEFINE('UNREAD.ATOM(L)')
  796.      UNREAD...Q. = POS(0) ('"' | "'") $ UNREAD...P.
  797. +     RTAB(1) *UNREAD...P.
  798. +     :(UNREAD.ATOM.END)
  799. UNREAD.ATOM
  800.        L = ATOM(L) CONVERT(L,"STRING")   :F(FRETURN)
  801.        L = IDENT(L) '""'      :S(UNREAD.ATOM1)
  802.        L BREAK(' ')           :F(UNREAD.ATOM1)
  803.        L UNREAD...Q.     :S(UNREAD.ATOM1)
  804.        L = '"' L '"'
  805. UNREAD.ATOM1
  806.        UNREAD.ATOM = L   :(RETURN)
  807. UNREAD.ATOM.END
  808. *
  809. * This is the main conversion routine
  810. *
  811.  DEFINE('UNREAD(L)')    :(UNREAD.END)
  812. UNREAD
  813.        UNREAD = UNREAD.NIL(L)       :S(RETURN)
  814.        UNREAD = UNREAD.DOTPAIR(L)   :S(RETURN)
  815.        UNREAD = UNREAD.SINGLETON(L) :S(RETURN)
  816.        UNREAD = UNREAD.REGULAR(L)   :S(RETURN)
  817.        UNREAD = UNREAD.ATOM(L)      :S(RETURN)
  818.        TDUMP('UNREAD',1)
  819. UNREAD.END   OPSYN('!', .UNREAD, 1)
  820.  
  821. *
  822. * The mapping function package
  823. *
  824. * MAP, MAPC, MAPLIST, MAPCAR, MAPCON, & MAPCAN
  825. *
  826.  DEXTERN('MAP(FN,L)')
  827. *
  828.  DEXTERN('MAPC(FN,L)')
  829. *
  830.  DEXTERN('MAPLIST(FN,L)R')
  831. *
  832.  DEFINE('MAPCAR(FN,L)A,R')          :(MAPCAR.END)
  833. MAPCAR
  834.       MAPCAR   =
  835. +         ( STRINGARG(.MAPCAR,1,.FN)
  836. +            LISTARG(.MAPCAR,2,.L) )
  837. +              NIL
  838. MAPCAR1  A = POP( .L)    :F(MAPCAR2)
  839.       R = APPLY(FN,A)    :F(FRETURN)
  840.       MAPCAR = R ~ MAPCAR      :(MAPCAR1)
  841. MAPCAR2  MAPCAR = LREVERSE(MAPCAR)       :(RETURN)
  842. MAPCAR.END
  843. *
  844.  DEFINE('MAPCARV(FN,L)A,R')    :(MAPCARV.END)
  845. MAPCARV
  846.       MAPCARV  =
  847. +        ( STRINGARG(.MAPCARV,1,.FN)
  848. +           LISTARG(.MAPCARV,2,.L) )
  849. +              NIL
  850. MAPCARV1  A =  POP( .L)  :F(RETURN)
  851.       R = APPLY(FN,A)    :F(FRETURN)
  852.       MAPCARV  = R ~ MAPCARV     :(MAPCARV1)
  853. MAPCARV.END
  854. *
  855.  DEXTERN('MAPCON(FN,L)')
  856. *
  857.  DEXTERN('MAPCAN(FN,L)')
  858. *
  859.  DEXTERN('EVERY(FN,L)A,V')
  860. *
  861.  DEXTERN('EVLIS(EV...L.)EV...T.')
  862. *
  863.  DEXTERN('SOME(FN,L)A,V')
  864. *
  865.  DEXTERN('SUBSET(FN,L)A,V')
  866.  
  867. *
  868. * A nice arithmetic package from Gimpel (1976), Chapter 15
  869. *
  870. *
  871. * Mathematical constants
  872. *
  873.  P...I. = 3.14159265358979
  874.  LN...10. = 2.3025850929940456840
  875.  NAT...BASE. = 2.718281828459045
  876. *
  877.  DEXTERN('FLOOR(X)')
  878. *
  879.  DEXTERN('CEIL(X)')
  880. *
  881.  DEXTERN('SQRT(Y)T')
  882. *
  883.  DEXTERN('RAD(D)')
  884. *
  885.  DEXTERN('DEG(R)')
  886. *
  887.  DEXTERN('SIN(A)K')
  888. *
  889.  DEXTERN('COS(A,S)K')
  890. *
  891.  DEXTERN('TAN(Z)')
  892. *
  893.  DEXTERN('ACOS(X)K,TERM,T')
  894. *
  895.  DEXTERN('ASIN(X)')
  896. *
  897.  DEXTERN('ATAN(X)')
  898. *
  899.  DEXTERN('LOG(X,B)')
  900. *
  901.  DEXTERN('CLOG(X)FACTOR,T,K')
  902. *
  903.  DEXTERN('RAISE(X,Y)')
  904.  DEXTERN('EXP(X)TERM,K,T')
  905. *
  906. * End of arithmetic package
  907. *
  908. *
  909. * Sort routine:  A variant of Quicksort
  910. *
  911. *
  912.  DEXTERN('SORT.(A,II,JJ,P)IU,IL,M,I,J,K,IJ,T,L,TT')
  913. *
  914. * Convert array to list
  915.  DEXTERN( 'CAL(A)N' )
  916. *
  917. * Convert list to array
  918. *
  919.  DEXTERN( 'CLA(L)N' )
  920. *
  921. ******     End of core functions
  922. *
  923. *
  924.