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