! ! Output stream, formatting ! module outstream integer :: outstr ! stream integer :: logstr ! logging stream character (len=1) :: tabsep = ' ' ! character to separate output words end module outstream ! ! Input buffer, prompt string etc ! ilevel=0 historical or macro command; =1 keyboard; =2,3 files ! ilevold=last level, if ilevel currently 0 ! module iobuff integer, parameter :: NSTRM=4, STDIN=5, STDOUT=6 integer, parameter :: LINSIZ = 20000 character (len=LINSIZ) :: commands, lin, scheme_lin character (len=3):: prompt_string = '>> ' integer :: ilevel=1, ilevold=1 integer, dimension(NSTRM) :: incstr = (/STDIN, 4, 10, 12/) character(len=256), dimension(2:NSTRM) :: infil=' ' end module iobuff ! ! Statistical functions library ! module statfuns contains ! ! betacf from Numerical Recipes, 1986 ! function betacf(a,b,x) double precision betacf double precision, intent(in) :: a double precision, intent(in) :: b double precision, intent(in) :: x double precision :: qab,qap,qam double precision :: bz,d,ap,bp,app,bpp,am,bm,az,aold,tem,em integer, parameter :: itmax=100 double precision, parameter :: eps=3.0d-7 am=1.0d0 bm=1.0d0 az=1.0d0 qab=a+b qap=a+1.0d0 qam=a-1.0d0 bz=1.0d0-qab*x/qap do m=1,itmax em=m tem=em+em d=em*(b-m)*x/((qam+tem)*(a+tem)) ap=az+d*am bp=bz+d*bm d=-(a+em)*(qab+em)*x/((a+tem)*(qap+tem)) app=ap+d*az bpp=bp+d*bz aold=az am=ap/bpp bm=bp/bpp az=app/bpp bz=1.0d0 if (dabs(az-aold) < eps*dabs(az)) go to 1 end do write(*,'(a/)') 'ERROR: In betacf().' 1 betacf=az end function betacf ! ! This function computes the beta cumulative ! distribution function at the point x. p and q are the ! exponents of x and 1-x in the beta density. see KL Majumder ! GP Bhattacharjee (1973). Algorithm AS 63 The incomplete beta ! integral. Appl Stat 22: 409-411. ! function ibeta(x, p, q) implicit none double precision :: ibeta double precision, intent(in) :: p, q, x integer :: ifault logical :: left double precision :: b, cx, first, pp, qq, sumpq, term, xx ! functions ! double precision alngam ! if (x.le.0.d0) then ibeta=1.d0 return else if (x.ge.1.d0) then ibeta=0.d0 return end if ! ! decide if x is to the left or right of the mean p/sumpq. ! sumpq=p+q if (p >= x*sumpq) then left=.true. cx=1.d0-x xx=x pp=p qq=q else left=.false. cx=x xx=1.d0-x pp=q qq=p end if ! ! intialize terms. ! b=alngam(sumpq, ifault)-alngam(pp, ifault)-alngam(qq+1.d0, ifault) term=exp((pp-1.d0)*log(xx)+qq*log(cx)+b) first=term ibeta=0.d0 ! ! use the integration by parts formula to raise pp and lower qq. ! do while (qq > 1.d0) term=xx*qq*term/(pp*cx) ibeta=ibeta+term if (term/first.lt.1.d-10) then if (left) ibeta=1.d0-ibeta return end if pp=pp+1.d0 qq=qq-1.d0 end do ! ! use Soper's formula to raise pp. ! term=qq*term do while (term/first >= 1.d-10) term=xx*term/pp ibeta=ibeta+term term=sumpq*term pp=pp+1.d0 sumpq=sumpq+1.d0 end do if (left) ibeta=1.d0-ibeta end function ibeta ! ! F-ratio P-values ! function fp(x, n1, n2) double precision :: fp double precision, intent(in) :: x integer, intent(in) :: n1, n2 ! functions ! double precision :: chip, ibeta if (n2 > 4.0d5) then if (n1 > 4.0d5) then if (x < 1) then fp=0.0d0 else if (x == 1) then fp=0.5d0 else fp=1.0d0 end if else fp=chip(x*dfloat(n1), n1) end if else if (n1 > 4.0d5) then fp=chip(dfloat(n2)/x, n2) else if (dfloat(n1)*x > dfloat(n2)) then fp=1.0d0-ibeta(dfloat(n2)/(dfloat(n2)+dfloat(n1)*x), 0.5d0*dfloat(n2), 0.5d0*dfloat(n1)) else fp=ibeta(dfloat(n1)*x/(dfloat(n2)+dfloat(n1)*x), 0.5d0*dfloat(n1), 0.5d0*dfloat(n2)) end if end function fp ! ! Wrap fp to give t-distribution P-values ! function tp(x, df) double precision :: tp double precision, intent(in) :: x integer, intent(in) :: df ! functions ! double precision :: fp tp=0.5d0*fp(x*x,1,df) end function tp ! ! Evaluate central chi-square in FORTRAN ! function chip(chisq, df) double precision chip double precision, intent(in) :: chisq integer, intent(in) :: df integer :: ifault double precision :: p, v, z double precision, parameter :: onethird=1.0d0/3.0d0, twoninths=2.0d0/9.0d0 ! functions ! double precision :: gammad, zp if (df <= 0 .or. chisq <= 0.0d0) then chip=1.0d0 return end if if (df == 1) then z=sqrt(chisq) p=2*zp(z) else p=1.0d0-gammad(0.5d0*chisq, 0.5d0*dfloat(df), ifault) end if if (p == 0.0d0 .and. df > 1) then v=twoninths/dfloat(df) z=((chisq/dfloat(df))**onethird-1.0d0+v)/sqrt(v) p=zp(z) end if chip=p end function chip ! ! Algorithm AS239 Appl. Statist. (1988) Vol. 37, No. 3 ! ! Computation of the Incomplete Gamma Integral ! function gammad(x, p, ifault) double precision gammad double precision, intent(in) :: x double precision, intent(in) :: p integer, intent(in out) :: ifault double precision :: pn1, pn2, pn3, pn4, pn5, pn6, & arg, c, rn, a, b, an double precision, parameter :: zero = 0.d0 double precision, parameter :: one = 1.d0 double precision, parameter :: two = 2.d0 double precision, parameter :: oflo = 1.d+37 double precision, parameter :: three = 3.d0 double precision, parameter :: nine = 9.d0 double precision, parameter :: tol = 1.d-14 double precision, parameter :: xbig = 1.d+8 double precision, parameter :: plimit = 1000.d0 double precision, parameter :: elimit = -88.d0 gammad = zero ! Check that we have valid values for X and P ! if (p .le. zero .or. x .lt. zero) then ! ifault = 1 ! return ! end if ! ifault = 0 ! if (x .eq. zero) return ! Use a normal approximation if P > PLIMIT if (p > plimit) then pn1 = three * sqrt(p) * ((x / p) ** (one / three) + one / (nine * p) - one) gammad = 1.0D0-zp(pn1) return end if ! If X is extremely large compared to P then set GAMMAD = 1 if (x > xbig) then gammad = one return end if if (x <= one .or. x < p) then ! Use Pearson's series expansion. ! (Note that P is not large enough to force overflow in ALNGAM). ! No need to test IFAULT on exit since P > 0. arg = p * log(x) - x - alngam(p + one, ifault) c = one gammad = one a = p 40 a = a + one c = c * x / a gammad = gammad + c if (c > tol) go to 40 arg = arg + log(gammad) gammad = zero if (arg >= elimit) gammad = exp(arg) else ! Use a continued fraction expansion arg = p * log(x) - x - alngam(p, ifault) a = one - p b = a + x + one c = zero pn1 = one pn2 = x pn3 = x + one pn4 = x * b gammad = pn3 / pn4 60 a = a + one b = b + two c = c + one an = a * c pn5 = b * pn3 - an * pn1 pn6 = b * pn4 - an * pn2 if (abs(pn6) > zero) then rn = pn5 / pn6 if (abs(gammad - rn) <= min(tol, tol * rn)) go to 80 gammad = rn end if pn1 = pn3 pn2 = pn4 pn3 = pn5 pn4 = pn6 if (abs(pn5) >= oflo) then ! Re-scale terms in continued fraction if terms are large pn1 = pn1 / oflo pn2 = pn2 / oflo pn3 = pn3 / oflo pn4 = pn4 / oflo end if go to 60 80 arg = arg + log(gammad) gammad = one if (arg >= elimit) gammad = one - exp(arg) end if return end function gammad ! ! ALGORITHM AS245 APPL. STATIST. (1989) VOL. 38, NO. 2 ! Calculation of the logarithm of the gamma function ! double precision function alngam(xvalue, ifault) double precision, intent(in) :: xvalue integer, intent(out) :: ifault double precision :: alr2pi, four, half, one, onep5, r1(9), r2(9), & r3(9), r4(5), twelve, x, x1, x2, xlge, xlgst, y, zero ! Coefficients of rational functions data r1/-2.66685511495D0, -2.44387534237D1, & -2.19698958928D1, 1.11667541262D1, 3.13060547623D0, 6.07771387771D-1, & 1.19400905721D1, 3.14690115749D1, 1.52346874070D1/ data r2/-7.83359299449D1, -1.42046296688D2, & 1.37519416416D2, 7.86994924154D1, 4.16438922228D0, 4.70668766060D1, & 3.13399215894D2, 2.63505074721D2, 4.33400022514D1/ DATA r3/-2.12159572323D5, 2.30661510616D5, & 2.74647644705D4, -4.02621119975D4, -2.29660729780D3, -1.16328495004D5, & -1.46025937511D5, -2.42357409629D4, -5.70691009324D2/ DATA r4/ 2.79195317918525D-1, 4.917317610505968D-1, & 6.92910599291889D-2, 3.350343815022304D0, 6.012459259764103D0/ ! Fixed constants DATA alr2pi/9.18938533204673D-1/, four/4.d0/, half/0.5D0/, & one/1.d0/, onep5/1.5D0/, twelve/12.d0/, zero/0.d0/ ! Machine-dependant constants. ! A table of values is given at the top of page 399 of the paper. ! These values are for the IEEE double-precision format for which ! B = 2, t = 53 and U = 1023 in the notation of the paper. DATA xlge/5.10D6/, xlgst/1.d+305/ x = xvalue alngam = zero ! Test for valid function argument ifault = 2 IF (x >= xlgst) RETURN ifault = 1 IF (x <= zero) RETURN ifault = 0 ! Calculation for 0 < X < 0.5 and 0.5 <= X < 1.5 combined IF (x < onep5) THEN IF (x < half) THEN alngam = -LOG(x) y = x + one ! Test whether X < machine epsilon IF (y == one) RETURN ELSE alngam = zero y = x x = (x - half) - half END IF alngam = alngam + x * ((((r1(5)*y + r1(4))*y + r1(3))*y & + r1(2))*y + r1(1)) / ((((y + r1(9))*y + r1(8))*y + r1(7))*y + r1(6)) RETURN END IF ! Calculation for 1.5 <= X < 4.0 IF (x < four) THEN y = (x - one) - one alngam = y * ((((r2(5)*x + r2(4))*x + r2(3))*x + r2(2))*x & + r2(1)) / ((((x + r2(9))*x + r2(8))*x + r2(7))*x + r2(6)) RETURN END IF ! Calculation for 4.0 <= X < 12.0 IF (x < twelve) THEN alngam = ((((r3(5)*x + r3(4))*x + r3(3))*x + r3(2))*x + r3(1)) / & ((((x + r3(9))*x + r3(8))*x + r3(7))*x + r3(6)) RETURN END IF ! Calculation for X >= 12.0 y = LOG(x) alngam = x * (y - one) - half * y + alr2pi IF (x > xlge) RETURN x1 = one / x x2 = x1 * x1 alngam = alngam + x1 * ((r4(3)*x2 + r4(2))*x2 + r4(1)) / & ((x2 + r4(5))*x2 + r4(4)) RETURN END FUNCTION alngam ! ! ALGORITHM AS 275 APPL.STATIST. (1992), VOL.41, NO.2 ! ! Computes the noncentral chi-square distribution function ! with positive real degrees of freedom f and nonnegative ! noncentrality parameter theta ! function chi2nc(x, f, ncp, ifault) double precision :: chi2nc double precision :: x, f, ncp integer :: ifault logical :: flag double precision :: lam, n, u, v, x2, f2, t, term, bound ! functions ! double precision :: alngam integer :: ITRMAX double precision :: ERRMAX, ZERO, ONE, TWO data ERRMAX, ITRMAX / 1.0E-6, 50 / data ZERO, ONE, TWO / 0.0d0, 1.0d0, 2.0d0 / chi2nc = x ifault = 2 if (f <= ZERO .or. ncp < ZERO) return ifault = 3 if (x < ZERO) return ifault = 0 if (x == zero) return lam = ncp / TWO ! ! Evaluate the first term ! n = ONE u = exp(-lam) v = u x2 = x / TWO f2 = f / TWO t = x2 ** f2 * exp(-x2) / exp(alngam((f2 + ONE), ifault)) ! ! There is no need to test IFAULT si ! already been checked ! term = v * t chi2nc = term ! ! Check if (f+2n) is greater than x ! flag = .false. 10 if ((f + TWO * n - x) <= ZERO) go to 30 ! ! Find the error bound and check for convergence ! flag = .true. 20 bound = t * x / (f + two * n - x) if (bound > ERRMAX .and. int(n) <= ITRMAX) go to 30 if (bound > ERRMAX) ifault = 1 return ! ! Evaluate the next term of the expansion and then the ! partial sum ! 30 u = u * lam / n v = v + u t = t * x / (f + two * n) term = v * t chi2nc = chi2nc + term n = n + one if (flag) go to 20 go to 10 end function chi2nc ! ! Alan Miller's zp ! Normal distribution probabilities accurate to 1.e-15. ! Z = no. of standard deviations from the mean. ! Based upon algorithm 5666 for the error function, from: ! Hart, J.F. et al, 'Computer Approximations', Wiley 1968 ! function zp(z) double precision :: zp double precision :: z, p, expntl, zabs double precision, parameter :: & p0 = 220.2068679123761D0, & p1 = 221.2135961699311D0, & p2 = 112.0792914978709D0, & p3 = 33.91286607838300D0, & p4 = 6.373962203531650D0, & p5 = .7003830644436881D0, & p6 = .03526249659989109D0 double precision, parameter :: & q0 = 440.4137358247522D0, & q1 = 793.8265125199484D0, & q2 = 637.3336333788311D0, & q3 = 296.5642487796737D0, & q4 = 86.78073220294608D0, & q5 = 16.06417757920695D0, & q6 = 1.755667163182642D0, & q7 = .08838834764831844D0 double precision, parameter :: & rootpi = 2.506628274631001D0, & cutoff = 7.071067811865475D0 zabs = abs(z) ! ! |Z| > 37 ! if (zabs > 37) then p = 0 else ! ! |z| <= 37 ! expntl = exp( -zabs**2/2 ) ! ! |z| < cutoff = 10/sqrt(2) ! if (zabs < cutoff) then p = expntl*( (((((p6*zabs + p5)*zabs + p4)*zabs + p3)*zabs & + p2)*zabs + p1)*zabs + p0)/(((((((q7*zabs + q6)*zabs & + q5)*zabs + q4)*zabs + q3)*zabs + q2)*zabs + q1)*zabs & + q0 ) ! ! |z| >= cutoff. ! else p = expntl/( zabs + 1/( zabs + 2/( zabs + 3/( zabs & + 4/( zabs + 0.65d0 ) ) ) ) )/rootpi end if end if if (z < 0) p=1-p zp=p end function zp ! ! A function for computing bivariate normal probabilities; ! developed using ! Drezner, Z. and Wesolowsky, G. O. (1989), ! On the Computation of the Bivariate Normal Integral, ! J. Stat. Comput. Simul.. 35 pp. 101-107. ! with extensive modications for double precisions by ! Alan Genz and Yihong Ge ! Department of Mathematics ! Washington State University ! Pullman, WA 99164-3113 ! Email : alangenz@wsu.edu ! ! BVN - calculate the probability that X is larger than SH and Y is ! larger than SK. ! ! Parameters ! ! SH REAL, integration limit ! SK REAL, integration limit ! R REAL, correlation coefficient ! LG INTEGER, number of Gauss Rule Points and Weights ! function mvbvu(sh, sk, r) double precision :: mvbvu double precision, intent(in) :: sh, sk, r double precision, parameter :: ZERO = 0, TWOPI = 6.283185307179586D0 integer :: i, lg, ng double precision, dimension(10, 3) :: x, w double precision :: as, a, b, c, d, rs, xs double precision :: bvn, sn, asr, h, k, bs, hs, hK save x, w ! functions ! double precision :: zp ! Gauss Legendre Points and Weights, N = 6 data ( w(i,1), x(i,1), i = 1, 3 ) / & 0.1713244923791705D+00,-0.9324695142031522D+00, & 0.3607615730481384D+00,-0.6612093864662647D+00, & 0.4679139345726904D+00,-0.2386191860831970D+00/ ! Gauss Legendre Points and Weights, N = 12 data ( W(I,2), X(I,2), I = 1, 6 ) / & 0.4717533638651177D-01,-0.9815606342467191D+00, & 0.1069393259953183D+00,-0.9041172563704750D+00, & 0.1600783285433464D+00,-0.7699026741943050D+00, & 0.2031674267230659D+00,-0.5873179542866171D+00, & 0.2334925365383547D+00,-0.3678314989981802D+00, & 0.2491470458134029D+00,-0.1252334085114692D+00/ ! Gauss Legendre Points and Weights, N = 20 data ( W(I,3), X(I,3), I = 1, 10 ) / & 0.1761400713915212D-01,-0.9931285991850949D+00, & 0.4060142980038694D-01,-0.9639719272779138D+00, & 0.6267204833410906D-01,-0.9122344282513259D+00, & 0.8327674157670475D-01,-0.8391169718222188D+00, & 0.1019301198172404D+00,-0.7463319064601508D+00, & 0.1181945319615184D+00,-0.6360536807265150D+00, & 0.1316886384491766D+00,-0.5108670019508271D+00, & 0.1420961093183821D+00,-0.3737060887154196D+00, & 0.1491729864726037D+00,-0.2277858511416451D+00, & 0.1527533871307259D+00,-0.7652652113349733D-01/ if (abs(r) < 0.3d0) then ng = 1 lg = 3 else if ( abs(r) < 0.75d0) then ng = 2 lg = 6 else ng = 3 lg = 10 end if h = sh k = sk hk = h*k bvn = 0.0d0 if ( abs(r) < 0.925d0) then hs = (h*h + k*k)/2 asr = asin(r) do i = 1, lg sn = sin(asr*( x(i,ng)+1 )/2) bvn = bvn + w(i,ng)*exp((sn*hk-hs)/(1-sn*sn)) sn = sin(asr*(-x(i,ng)+1 )/2) bvn = bvn + w(i,ng)*exp((sn*hk-hs)/(1-sn*sn)) end do bvn = bvn*asr/(2*twopi) + zp(-h)*zp(-k) else if (r < 0.0d0) then k = -k hk = -hk end if if (abs(r) < 1.0d0) then as = (1-r)*(1+r) a = sqrt(as) bs = (h-k)**2 c = ( 4 - hk )/8 d = ( 12 - hk )/16 bvn = a*exp( -(bs/as + hk)/2 ) & *( 1 - c*(bs - as)*(1 - d*bs/5)/3 + c*d*as*as/5 ) if (hk > -160d0) then b = sqrt(bs) bvn = bvn - exp(-hk/2)*sqrt(twopi)*zp(-b/a)*b & *( 1 - c*bs*( 1 - d*bs/5 )/3 ) end if a = a/2 do i = 1, lg xs = ( a*(x(i,ng)+1) )**2 rs = sqrt(1 - xs) bvn = bvn + a*w(i,ng)* & ( exp( -bs/(2*xs) - hk/(1+rs) )/rs & - exp( -(bs/xs+hk)/2 )*( 1 + c*xs*( 1 + d*xs ) ) ) xs = as*(-x(i,ng)+1)**2/4 rs = sqrt(1 - xs) bvn = bvn + a*w(i,ng)*exp( -(bs/xs + hk)/2 ) & *( exp( -hk*(1-rs)/(2*(1+rs)) )/rs & - ( 1 + c*xs*( 1 + d*xs ) ) ) end do bvn = -bvn/twopi end if if ( r > 0.0d0) bvn = bvn + zp(-max(h, k)) if ( r < 0.0d0) bvn = -bvn + max( zero, zp(-h) - zp(-k) ) end if mvbvu = bvn end function mvbvu ! ! Algorithm AS 111, Appl.Statist., vol.26, 118-121, 1977. ! Produces normal deviate corresponding to lower tail area = p. ! DOUBLE PRECISION FUNCTION ppnd(p) DOUBLE PRECISION, INTENT(IN) :: p DOUBLE PRECISION :: q, r DOUBLE PRECISION :: a0, a1, a2, a3, b1, b2, b3, b4, & c0, c1, c2, c3, d1, d2, split DOUBLE PRECISION :: half, one, zero DATA split/0.42D0/ DATA a0,a1,a2,a3/2.50662823884D0,-18.61500062529D0, & 41.39119773534D0,-25.44106049637D0/, b1,b2,b3,b4/ & -8.47351093090D0,23.08336743743D0,-21.06224101826D0, & 3.13082909833D0/, c0,c1,c2,c3/-2.78718931138D0,-2.29796479134D0, & 4.85014127135D0,2.32121276858D0/, d1,d2/3.54388924762D0, 1.63706781897D0/ DATA zero/0.d0/, one/1.d0/, half/0.5D0/ q = p-half IF (ABS(q) > split) GO TO 10 ! 0.08 < p < 0.92 r = q*q ppnd = q*(((a3*r + a2)*r + a1)*r + a0)/((((b4*r + b3)*r + b2)*r + b1)*r + one) RETURN ! p < 0.08 or p > 0.92, set r = min(p,1-p) 10 r = p IF (q > zero) r = one-p IF (r <= zero) GO TO 20 r = SQRT(-LOG(r)) ppnd = (((c3*r + c2)*r + c1)*r + c0)/((d2*r + d1)*r + one) IF (q < zero) ppnd = -ppnd RETURN 20 CONTINUE ppnd = zero RETURN END FUNCTION ppnd ! ! Richard Goldstein, Algorithm 451: Chi-Square Quantiles, ! Communications of the ACM, August 1973, Volume 16, Number 8, pages 483-484. ! Transcribed to machine readable form by John Burkhardt ! function chisqd(p, n) double precision :: chisqd integer, intent(in) :: n double precision, intent(in) :: p double precision :: f, f1, t double precision, dimension(19) :: A double precision, dimension(21) :: C ! functions ! double precision :: ppnd data c(1)/1.565326e-3/, c(2)/1.060438e-3/, & c(3)/-6.950356e-3/, c(4)/-1.323293e-2/, & c(5)/2.277679e-2/, c(6)/-8.986007e-3/, & c(7)/-1.513904e-2/, c(8)/2.530010e-3/, & c(9)/-1.450117e-3/, c(10)/5.169654e-3/, & c(11)/-1.153761e-2/, c(12)/1.128186e-2/, & c(13)/2.607083e-2/, c(14)/-0.2237368/, & c(15)/9.780499e-5/, c(16)/-8.426812e-4/, & c(17)/3.125580e-3/, c(18)/-8.553069e-3/, & c(19)/1.348028e-4/, c(20)/0.4713941/, c(21)/1.0000886/ data a(1)/1.264616e-2/, a(2)/-1.425296e-2/, & a(3)/1.400483e-2/, a(4)/-5.886090e-3/, & a(5)/-1.091214e-2/, a(6)/-2.304527e-2/, & a(7)/3.135411e-3/, a(8)/-2.728484e-4/, & a(9)/-9.699681e-3/, a(10)/1.316872e-2/, & a(11)/2.618914e-2/, a(12)/-0.2222222/, & a(13)/5.406674e-5/, a(14)/3.483789e-5/, & a(15)/-7.274761e-4/, a(16)/3.292181e-3/, & a(17)/-8.729713e-3/, a(18)/0.4714045/, a(19)/1./ chisqd = 0.0d0 if (n <= 0 .or. p > 1.0d0 .or. p < 0.0d0) then return else if (n == 1) then chisqd = ppnd(0.5d0*p) chisqd = chisqd*chisqd return else if (n == 2) then chisqd = -2 * log(p) return else f = n f1 = 1.0D0 / f t = ppnd(1-p) f2 = sqrt(f1) * t if ( n < (2+int(4*abs(T)))) then chisqd =(((((((c(1)*f2+c(2))*f2+c(3))*f2+c(4))*f2 & +c(5))*f2+c(6))*f2+c(7))*f1+((((((c(8)+c(9)*f2)*f2 & +c(10))*f2+c(11))*f2+c(12))*f2+c(13))*f2+c(14)))*f1 + & (((((c(15)*f2+c(16))*f2+c(17))*f2+c(18))*f2 & +c(19))*f2+c(20))*f2+c(21) else chisqd = (((a(1)+a(2)*f2)*f1+(((a(3)+a(4)*f2)*f2 & +a(5))*f2+a(6)))*f1+(((((a(7)+a(8)*f2)*f2+a(9))*f2 & +a(10))*f2+a(11))*f2+a(12)))*f1 + (((((a(13)*f2 & +a(14))*f2+a(15))*f2+a(16))*f2+a(17))*f2*f2 & +a(18))*f2+a(19) end if chisqd = chisqd*chisqd*chisqd*f return end if end function chisqd end module statfuns ! ! time/random number generator seeds ! module rndseed integer :: ix,iy,iz integer :: initix,initiy,initiz end module rndseed ! ! random number generators ! module rngs contains ! ! Return a pseudo-random integer from integer U(lo..hi) ! integer function irandom(lo,hi) integer, intent(in) :: lo integer, intent(in) :: hi real :: x x=random() irandom=lo+int(float(hi-lo+1)*x) if (irandom > hi) irandom=hi end function irandom ! ! Algorithm AS 183 Appl Stat 1982; 31:188 ! Returns a pseudo-random number from U(0,1) ! ! ix,iy,iz should be "randomly" initialised to 1-30000 ! eg via time ! function random() use rndseed real :: random ix=171*mod(ix,177)-2*(ix/177) iy=172*mod(iy,176)-35*(iy/176) iz=170*mod(iz,178)-63*(iz/178) if (ix < 0) ix=ix+30269 if (iy < 0) iy=iy+30307 if (iz < 0) iz=iz+30323 random=amod(float(ix)/30269.0+float(iy)/30307.0 + float(iz)/30323.0,1.0) end function random end module rngs ! ! String handling functions used by scheme ! module string_utilities contains ! ! character to integer conversion via internal read ! function ival(string) use outstream integer :: ival character(len=*), intent(in) :: string integer, parameter :: MISS=-9999 integer :: i, ioerr if (string == ' ') then ival=0 elseif (string == 'x' .or. string == 'X' .or. & string == '.' .or. string == 'NA') then ival=MISS else read(string,'(i40)',iostat=ioerr) i if (ioerr==0) then ival=i else write(outstr,'(2a/)') 'ERROR: Unable to read integer ',string ival=0 end if end if end function ival ! ! character to float conversion via internal read ! function fval(string) use outstream double precision :: fval integer, parameter :: BLANKD=-9999, MISS=-9999 character(len=*), intent(in) :: string integer :: ioerr double precision :: v if (string == ' ' .or. string == '-') then fval=BLANKD elseif (string == 'x' .or. string == 'X' .or. & string == '.' .or. string == 'NA') then fval=MISS elseif (string == 'y' .or. string == 'Y') then fval=2.0d0 elseif (string == 'n' .or. string == 'N') then fval=1.0d0 else read(string,'(f40.0)',iostat=ioerr) v if (ioerr == 0) then fval=v else write(outstr,'(2a/)') & 'ERROR: Unable to read double precision number ',string fval=0.0d0 end if end if end function fval ! ! Compare string to a search string, allowing wildcards '*.', and case ! matching ! function strfind(regexp, targt, nocase) logical :: strfind character (len=*), intent(in) :: regexp character (len=*), intent(in) :: targt integer, intent(in) :: nocase ! 1=respect 2=ignore integer :: i, ich1, ich2, lenr, lent, pos, wpos logical :: looking, wild lenr=len_trim(regexp) lent=len_trim(targt) ! while regexp and target not exhausted if (lent == 0 .or. lenr == 0) then strfind=.false. if (lenr == 1) strfind=(regexp(lenr:lenr) == '*') return end if i=1 pos=1 wpos=0 wild=.false. looking=.true. strfind=.true. do while (looking) if (regexp(pos:pos) == '*') then wild=.true. wpos=pos pos=pos+1 looking=(pos <= lenr) else ! this character matches? if (regexp(pos:pos) == '.' .and. .not.wild) then strfind=.true. else if (nocase == 2) then ich1=ichar(regexp(pos:pos)) ich2=ichar(targt(i:i)) if (ich1 >= 65 .and. ich1 <= 90) ich1=ich1+32 if (ich2 >= 65 .and. ich2 <= 90) ich2=ich2+32 strfind=(ich1 == ich2) else strfind=(regexp(pos:pos) == targt(i:i)) end if looking=strfind if (wild) then looking=.true. if (strfind) then wild=.false. else pos=wpos end if end if pos=pos+1 i=i+1 ! target exhausted? If regexp ends in wild card, then found if (i > lent) then looking=.false. if (regexp(pos:pos) == '*' .and. pos == lenr) wild=.true. if (pos <= lenr .and. .not.wild) strfind=.false. end if ! regexp exhausted? if regexp doesn't end in wild card, then not found ! so [-recycle completely-] exit if (pos > lenr) then if (i <= lent) then if (wild) then looking=.false. strfind=.true. else looking=.false. strfind=.false. end if end if ! if not exhausted and only partial match and previous wild card, then recycle else if (.not.strfind .and. wpos /= 0 .and. i <= lent) then looking=.true. pos=wpos+1 end if end if end do end function strfind end module string_utilities ! ! Scheme ! module scheme_lang use interrupt use outstream use iobuff private public :: cleanup_mem, get_string, get_var, isafun, list_var, init_scheme, & read_scheme_image, repl_scheme, save_scheme_image ! ! binary images of scheme workspace need to match correct version ! bump version number if eg add new procedures ! character (len=5), parameter :: scheme_version = '00003' integer, parameter :: T_FREE=0, T_STRING=1, T_NUMBER=2, T_SYMBOL=4, T_SYNTAX=8, & T_PROC=16, T_PAIR=32, T_CLOSURE=64, T_CONTINUATION=128, & T_MACRO=256, T_PROMISE=512, T_PORT=2048, T_ATOM=16384, & T_CLRATOM=49151, T_MARK=32768, T_UNMARK=32767, & T_MOVED=-1 integer, parameter :: M_LPAREN=0, M_RPAREN=1, M_DOT=2, M_ATOM=3, M_QUOTE=4, & M_COMMENT=5, M_DQUOTE=6, M_BQUOTE=7, M_COMMA=8, M_ATMARK=9, & M_SHARP=10 integer, parameter :: OP_LOAD=0, OP_T0LVL=1, OP_T1LVL=2, OP_READ=3, OP_VALUEPRINT=4, & OP_EVAL=5, OP_E0ARGS=6, OP_E1ARGS=7, OP_APPLY=8, OP_DOMACRO=9 integer, parameter :: OP_LAMBDA=10, OP_QUOTE=11, OP_DEF0=12, OP_DEF1=13, OP_BEGIN=14, & OP_IF0=15, OP_IF1=16, OP_SET0=17, OP_SET1=18, OP_LET0=19, OP_LET1=20, & OP_LET2=21, OP_LET0AST=22, OP_LET1AST=23, OP_LET2AST=24, OP_LET0REC=25, & OP_LET1REC=26, OP_LET2REC=27, OP_COND0=28, OP_COND1=29, OP_DELAY=30, & OP_AND0=31, OP_AND1=32, OP_OR0=33, OP_OR1=34, OP_C0STREAM=35, OP_C1STREAM=36, & OP_0MACRO=37, OP_1MACRO=38, OP_CASE0=39, OP_CASE1=40, OP_CASE2=41 integer, parameter :: OP_PEVAL=42, OP_PAPPLY=43, OP_CONTINUATION=44, OP_ADD=45, & OP_SUB=46, OP_MUL=47, OP_DIV=48, OP_INTDIV=49, OP_REM=50, OP_MOD=51, & OP_CAR=52, OP_CDR=53, OP_CONS=54, OP_SETCAR=55, & OP_SETCDR=56, OP_NOT=57, OP_BOOL=58, OP_ISINT=59, OP_ISREAL=60, & OP_NULL=61, OP_ZEROP=62, OP_POSP=63, & OP_NEGP=64, OP_NUMEQ=65, OP_LESS=66, OP_GRE=67, OP_LEQ=68, OP_GEQ=69, OP_SYMBOL=70, & OP_NUMBER=71, OP_STRING=72, OP_PROC=73, OP_PAIR=74, OP_EQ=75, OP_EQV=76, & OP_FORCE=77, OP_WRITE=78, OP_DISPLAY=79, OP_NEWLINE=80, OP_ERR0=81, & OP_ERR1=82, OP_REVERSE=83, OP_APPEND=84, OP_PUT=85, OP_GET=86, OP_QUIT=87, & OP_GC=88, OP_GCVERB=89, OP_NEWSEGMENT=90 integer, parameter :: OP_RDSEXPR=91, OP_RDLIST=92, OP_RDDOT=93, OP_RDQUOTE=94, OP_RDQQUOTE=95, & OP_RDUNQUOTE=96, OP_RDUQTSP=97 integer, parameter :: OP_P0LIST=98, OP_P1LIST=99, OP_LIST_LENGTH=100, OP_ASSQ=101, OP_PRINT_WIDTH=102, & OP_P0_WIDTH=103, OP_P1_WIDTH=104, OP_GET_CLOSURE=105, OP_CLOSUREP=106, & OP_MACROP=107 integer, parameter :: OP_EXP=108, OP_LOG=109, OP_SIN=110, OP_COS=111, & OP_TAN=112, OP_ASIN=113, OP_ACOS=114, OP_ATAN=115, & OP_SQRT=116, OP_TRUNCATE=117, OP_ROUND=118, & OP_ABS=119, OP_EXPT=120 integer, parameter :: OP_MIN=121, OP_MAX=122, OP_RANDOM=123 integer, parameter :: OP_MKSTRING=124, OP_STRLEN=125, OP_STRSET=126, & OP_SUBSTR=127, OP_STRAPPEND=128, OP_STRSPLIT=129, & OP_STREQ=130, OP_STRLT=131, OP_STRGT=132, & OP_STRLE=133, OP_STRGE=134, OP_STRFIND=135, & OP_CHAR2INT=136, OP_INT2CHAR=137, & OP_STR2NUM=138, OP_NUM2STR=139, & OP_SYM2STR=140, OP_STR2SYM=141 integer, parameter :: OP_SYSTEM=142, OP_IPORT=143, OP_OPORT=144, & OP_CLPORT=145, OP_CURR_INPORT=146, & OP_CURR_OUTPORT=147, OP_RDLINE=148, OP_FORMAT=149, & OP_FDATE=160, OP_GETENV=161, & OP_INQUIRE=162, OP_APROPOS=163, OP_HELP=164 integer, parameter :: OP_PNORM=165, OP_QNORM=166, OP_PCHISQ=167, & OP_QCHISQ=168, OP_PFDIST=169, OP_BIVNOR=170, & OP_GAMMAD=171, OP_ALNGAM=172 #if JAPI integer, parameter :: OP_JSTART=1001, OP_JQUIT=1002, OP_JFRAME=1003, & OP_JPANEL=1004, OP_JBORDERPANEL=1005, & OP_JDIALOG=1006, OP_JBUTTON=1007, & OP_JRADIOBUTTON=1008, OP_JRADIOGROUP=1009, & OP_JCHECKBOX=1010, OP_JLIST=1011, OP_JADD=1012, & OP_JSETCOLOR=1013, OP_JSETCOLORBG=1014, & OP_JSETNAMEDCOLORBG=1015, OP_JGETSELECT=1016, & OP_JSELECT=1017, OP_JDESELECT=1018, & OP_JFILESELECT=1019, OP_JFILEDIALOG=1020, & OP_JENABLE=1021, OP_JDISABLE=1022, OP_JADDITEM=1023, & OP_JSEPERATOR=1024, OP_JTEXTFIELD=1025, & OP_JTEXTAREA=1026, OP_JSETBORDERPOS=1027, & OP_JSETROWS=1028, OP_JSETCOLUMNS=1029, & OP_JGETROWS=1030, OP_JGETCOLUMNS=1031, & OP_JGETLENGTH=1032, OP_JGETSELSTART=1033, & OP_JGETSELEND=1034, OP_JSELECTTEXT=1035, & OP_JGETTEXT=1036, OP_JGETSELTEXT=1037, & OP_JGETITEM=1038, OP_JLABEL=1039, OP_JGETCURPOS=1040, & OP_JSETCURPOS=1041, OP_JSETFONT=1042, & OP_JSETTEXT=1043, OP_JINSERTTEXT=1044, & OP_JREPLACETEXT=1045, OP_JDELETE=1046, & OP_JDISPOSE=1047, OP_JMENUBAR=1048, OP_JMENU=1049, & OP_JMENUITEM=1050, OP_JPACK=1051, OP_JSHOW=1052, & OP_JHIDE=1053, OP_JKEYLISTENER=1054, & OP_JGETKEYCODE=1055, OP_JGETKEYCHAR=1056, & OP_JMOUSELISTENER=1057, OP_JGETMOUSEBUTTON=1058, & OP_JNEXTACTION=1059, OP_JGETWIDTH=1060, & OP_JGETHEIGHT=1061, OP_JGETPOS=1062, OP_JSETPOS=1063, & OP_SETSIZE=1064, OP_JSETALIGN=1065, & OP_JSETBORDERLAYOUT=1066, OP_JSETGRIDLAYOUT=1067, & OP_JSETFLOWLAYOUT=1068 #endif integer :: cell_segment = 500 integer :: infp=STDIN integer :: outfp=STDOUT integer :: currentline=0, eol=0 ! ! Scheme memory cell ! iflag is cell type T_FREE..T_MOVED ! value is number, either integer or transfer()'ed real ! slength, svalue is a character string ! keynum is procedure number or number type ! car, cdr point to preceding and succeeding cells ! type mcell integer :: iflag integer (kind=8) :: value integer :: slength character, dimension(:), allocatable :: svalue integer :: keynum integer :: car integer :: cdr end type mcell ! Special addresses integer :: nil=1 ! special cell representing empty cell integer :: t=2 ! special cell representing #t integer :: f=3 ! special cell representing #f integer :: un=4 ! special cell representing #unspecified integer :: global_env=1 ! pointer to global environment integer :: lambda=1 ! pointer to syntax lambda integer :: quote=1 integer :: qquote=1 integer :: unquote=1 integer :: unquotesp=1 ! registers integer :: scm_args=1 integer :: code=1 integer :: dump=1 integer :: envir=1 ! pointer to symbol table integer :: oblist=1 ! ! Evaluator globals ! integer :: oper=1 ! current operation integer :: tok=1 ! current token integer :: value=1 ! value of current expression integer :: print_flag=1 ! print expression ! ! Memory is memsiz array of mcells: mem(memsiz) ! ! memsiz = current maximum allocatable cells ! nextfree= address of next free cell ! fcell = number of free cells ! integer :: memsiz type (mcell), dimension(:), allocatable :: mem integer :: nextfree integer :: fcells ! ! input streams ! integer, parameter :: MAXPORT=5 integer, dimension(5) :: portaddress = (/21, 22, 23, 24, 25/) integer :: nports = 0 integer :: LOADSTR=26 character (len=512) :: loadfil contains ! Memory management subroutine setup_mem(siz) integer, intent(in) :: siz type (mcell), dimension(:), allocatable :: tmpmem integer :: j, slen if (.not.allocated(mem)) then memsiz=siz allocate(mem(memsiz)) do j=1, siz mem(j)%iflag=T_FREE mem(j)%value=0 mem(j)%slength=0 mem(j)%keynum=-1 mem(j)%car=nil mem(j)%cdr=nil end do mem(nil)%iflag=ior(T_ATOM, T_MARK) mem(t)%iflag=ior(T_ATOM, T_MARK) mem(f)%iflag=ior(T_ATOM, T_MARK) mem(un)%iflag=ior(T_ATOM, T_MARK) nextfree=5 fcells=memsiz-5 else if (siz > memsiz) then allocate(tmpmem(memsiz)) do j=1, memsiz tmpmem(j)%iflag=mem(j)%iflag tmpmem(j)%value=mem(j)%value slen=mem(j)%slength tmpmem(j)%slength=slen if (slen > 0) then allocate(tmpmem(j)%svalue(slen)) tmpmem(j)%svalue=mem(j)%svalue end if tmpmem(j)%keynum=mem(j)%keynum tmpmem(j)%car=mem(j)%car tmpmem(j)%cdr=mem(j)%cdr end do call cleanup_mem() allocate(mem(siz)) do j=1, memsiz mem(j)%iflag=tmpmem(j)%iflag mem(j)%value=tmpmem(j)%value slen=tmpmem(j)%slength mem(j)%slength=slen if (slen > 0) then allocate(mem(j)%svalue(slen)) mem(j)%svalue=tmpmem(j)%svalue deallocate(tmpmem(j)%svalue) end if mem(j)%keynum=tmpmem(j)%keynum mem(j)%car=tmpmem(j)%car mem(j)%cdr=tmpmem(j)%cdr end do do j=memsiz+1, siz mem(j)%iflag=T_FREE mem(j)%value=0 mem(j)%slength=0 mem(j)%car=nil mem(j)%cdr=nil mem(j)%keynum=-1 end do deallocate(tmpmem) if (nextfree == nil) then nextfree=memsiz+1 fcells=siz-memsiz end if memsiz=siz end if end subroutine setup_mem ! ! Clean up memory arrays ! ! Zero a block of cells, including deallocating strings ! subroutine cleanup_bank(sta, fin) integer, intent(in) :: fin, sta integer :: j do j=sta, fin if (allocated(mem(j)%svalue)) then mem(j)%slength=0 deallocate(mem(j)%svalue) else end if mem(j)%iflag=T_FREE mem(j)%value=0 mem(j)%keynum=-1 mem(j)%car=nil mem(j)%cdr=nil end do end subroutine cleanup_bank ! ! Free all memory ! subroutine cleanup_mem() call cleanup_bank(1, memsiz) deallocate(mem) end subroutine cleanup_mem ! ! Save memory image subroutine save_scheme_image(strm, ios) integer, intent(in) :: strm integer, intent(out) :: ios integer :: i ios=0 write(strm, iostat=ios) 'Sib-pair Scheme ' // scheme_version if (ios /= 0) return write(strm, iostat=ios) memsiz, nextfree, fcells if (ios /= 0) return write(strm) nil, t, f, un, & global_env, lambda, quote, qquote, unquote, unquotesp, & scm_args, code, dump, envir, oblist, oper, tok, value, & print_flag do i=1, memsiz write(strm) mem(i)%iflag, mem(i)%value, mem(i)%slength if (mem(i)%slength > 0) then write(strm) mem(i)%svalue(1:mem(i)%slength) end if write(strm) mem(i)%keynum, mem(i)%car, mem(i)%cdr end do end subroutine save_scheme_image ! ! Read memory image subroutine read_scheme_image(strm, ios) integer, intent(in) :: strm integer, intent(out) :: ios character (len=21) :: slin integer :: i, newmemsiz, newfree, newcells ! old dataset images do not contain a Scheme image - quietly abort read(strm, iostat=ios) slin if (ios /= 0 .or. slin /= 'Sib-pair Scheme ' // scheme_version) then ios=0 return end if call cleanup_mem() read(strm, iostat=ios) newmemsiz, newfree, newcells if (ios /= 0) return call setup_mem(newmemsiz) nextfree=newfree fcells=newcells read(strm) nil, t, f, un, & global_env, lambda, quote, qquote, unquote, unquotesp, & scm_args, code, dump, envir, oblist, oper, tok, value, & print_flag do i=1, memsiz read(strm) mem(i)%iflag, mem(i)%value, mem(i)%slength if (mem(i)%slength > 0) then allocate(mem(i)%svalue(mem(i)%slength)) read(strm) mem(i)%svalue(1:mem(i)%slength) end if read(strm) mem(i)%keynum, mem(i)%car, mem(i)%cdr end do end subroutine read_scheme_image ! ! Mark-sweep garbage collector ! ! Mark cells to be saved ! subroutine gc_mark(a) integer, intent(in) :: a integer :: p, q, t t=nil p=a 20 continue call setmark(p) if (isatom(p)) goto 60 q=car(p) if (q /= nil .and. .not.ismark(q)) then call setatom(p) call set_car(p, t) t=p p=q goto 20 end if 50 continue q=cdr(p) if (q /= nil .and. .not.ismark(q)) then call set_cdr(p, t) t=p p=q goto 20 end if 60 continue if (t == nil) return q=t if (isatom(q)) then call clratom(q) t=car(q) call set_car(q, p) p=q goto 50 else t=cdr(q) call set_cdr(q, p) p=q goto 60 end if end subroutine gc_mark ! ! Copy all registers to free memory ! Reset pointers from old addresses to new addresses ! subroutine gc(a, b, plevel) integer :: a, b integer, intent(in) :: plevel integer :: i nextfree=1 call gc_mark(nil) call gc_mark(t) call gc_mark(f) call gc_mark(un) call gc_mark(oblist) call gc_mark(global_env) call gc_mark(envir) call gc_mark(scm_args) call gc_mark(code) call gc_mark(dump) call gc_mark(a) call gc_mark(b) call clrmark(nil) fcells=0 nextfree=nil do i=1, memsiz if (ismark(i)) then call clrmark(i) else call cleanup_bank(i, i) call set_cdr(i, nextfree) nextfree = i fcells=fcells+1 end if end do if (plevel > 0) then write(*,*) 'GC recovered ', fcells, ' of ', memsiz, ' cells' write(*,*) 'nextfree=', nextfree end if end subroutine gc ! ! Get next free cell ! function getcell(a, b) integer :: getcell integer, intent(in) :: a, b integer :: newsiz, x if (nextfree == nil) then ! write(*,*) 'Run out of memory! calling GC' call gc(a, b, 0) ! write(*,*) 'Called GC, nextfree=', nextfree if (nextfree == nil) then ! write(*,*) 'memsiz=', memsiz newsiz=memsiz+cell_segment call setup_mem(newsiz) call gc(a, b, 0) ! write(*,*) 'Called GC again, memsiz=', memsiz, ' nextfree=', nextfree end if end if x=nextfree nextfree=cdr(x) fcells=fcells-1 call set_car(x, nil) call set_cdr(x, nil) getcell=x end function getcell ! ! Cell type operations ! ! Setting values subroutine set_type(p, iflag) integer, intent(in) :: p integer, intent(in) :: iflag mem(p)%iflag=iflag end subroutine set_type subroutine set_ivalue(p, ivalue) integer, intent(in) :: p integer (kind=8), intent(in) :: ivalue mem(p)%value=ivalue mem(p)%keynum=1 end subroutine set_ivalue subroutine set_value(p, val) integer, intent(in) :: p double precision, intent(in) :: val mem(p)%value=transfer(val, mem(p)%value) mem(p)%keynum=2 end subroutine set_value subroutine set_string(p, str) integer, intent(in) :: p character (len=*), intent(in) :: str integer :: i, slen if (allocated(mem(p)%svalue)) then deallocate(mem(p)%svalue) end if slen=len(str) mem(p)%slength=slen allocate(mem(p)%svalue(slen)) do i=1, slen mem(p)%svalue(i)=str(i:i) end do end subroutine set_string subroutine set_substring(p, sta, fin, str) integer, intent(in) :: p integer, intent(in) :: fin, sta character (len=*), intent(in) :: str integer :: i, pos pos=0 do i=sta, min(mem(p)%slength, fin) pos=pos+1 mem(p)%svalue(i)=str(pos:pos) end do end subroutine set_substring ! subroutine set_car(p, icar) integer, intent(in) :: icar, p mem(p)%car=icar end subroutine set_car subroutine set_cdr(p, icdr) integer, intent(in) :: icdr, p mem(p)%cdr=icdr end subroutine set_cdr subroutine set_caar(p, icaar) integer, intent(in) :: icaar, p mem(mem(p)%car)%car=icaar end subroutine set_caar subroutine set_cdar(p, icdar) integer, intent(in) :: icdar, p mem(mem(p)%car)%cdr=icdar end subroutine set_cdar subroutine set_syntaxnum(p, op) integer :: op, p mem(p)%keynum=op end subroutine set_syntaxnum ! ! Getting values ! function get_ivalue(p) integer (kind=8) :: get_ivalue integer, intent(in) :: p get_ivalue=mem(p)%value end function get_ivalue ! function get_value(p) double precision :: get_value integer, intent(in) :: p get_value=transfer(mem(p)%value, get_value) end function get_value ! function rvalue(p) double precision :: rvalue integer, intent(in) :: p if (mem(p)%keynum == 2) then rvalue=transfer(mem(p)%value, rvalue) else rvalue=dble(mem(p)%value) end if end function rvalue ! ! Strings ! function get_string(p) integer, intent(in) :: p character (len=mem(p)%slength) :: get_string integer :: i get_string=' ' if (mem(p)%slength > 0) then do i=1, mem(p)%slength get_string(i:i)=mem(p)%svalue(i) end do end if end function get_string ! ! Append to existing string ! subroutine append_string(p, str) integer, intent(in) :: p character (len=*), intent(in) :: str character (len=mem(p)%slength) :: buff integer :: i, slen, sta slen=len(str) if (.not.allocated(mem(p)%svalue)) then sta=0 mem(p)%slength=slen allocate(mem(p)%svalue(slen)) else buff=get_string(p) sta=mem(p)%slength mem(p)%slength=sta+slen deallocate(mem(p)%svalue) allocate(mem(p)%svalue(sta+slen)) end if do i=1, sta mem(p)%svalue(i)=buff(i:i) end do do i=1, slen mem(p)%svalue(sta+i)=str(i:i) end do end subroutine append_string ! Substring function get_substr(p, sta, fin) integer, intent(in) :: p, sta, fin character (len=(fin-sta)) :: get_substr integer :: i, j, slen get_substr=' ' slen=mem(p)%slength if (slen > 0) then j=0 do i=sta, min(slen,fin)-1 j=j+1 get_substr(j:j)=mem(p)%svalue(i+1) end do end if end function get_substr ! String length function get_strlen(p) integer :: get_strlen integer, intent(in) :: p get_strlen=mem(p)%slength end function get_strlen ! function get_listlen(p) integer :: get_listlen integer :: p integer :: l, x l=0 x=p do while (ispair(x)) l=l+1 x=cdr(x) end do if (x/=nil) l=-1 get_listlen=l end function get_listlen ! ! allowing access to Scheme environment from Sib-pair ! accessible variables are atomic ! result inserted into passed string ! subroutine get_var(string, pos, fin, istat) character (len=*), intent(inout) :: string integer, intent(inout) :: pos, fin integer, intent(out) :: istat integer :: eos, newlen, reslen, tmp, varend, varsta, x, y character (len=40) :: cbuff eos=len(string) istat=0 varsta=pos+1 varend=fin if (string(varsta:varsta) == '(') varsta=varsta+1 if (string(varend:varend) == ')') varend=varend-1 if (varsta <= varend) then tmp=oblist do while (tmp /= nil) if (ceqstr(string(varsta:varend), caar(tmp))) exit tmp=cdr(tmp) end do if (tmp == nil) then istat=-1 goto 999 end if tmp=car(tmp) x=envir do while (x /= nil) y=car(x) do while (y /= nil) if (caar(y) == tmp) exit y=cdr(y) end do if (y /= nil) exit x=cdr(x) end do if (x /= nil) then reslen=0 cbuff=' ' if (isstring(cdar(y)) .or. isport(cdar(y))) then istat=1 reslen=get_strlen(cdar(y)) else if (isnumber(cdar(y))) then istat=2 if (isinteger(cdar(y))) then write(cbuff, '(i20)') get_ivalue(cdar(y)) reslen=len_trim(adjustl(cbuff)) else write(cbuff, '(g20.12)') get_value(cdar(y)) reslen=len_trim(adjustl(cbuff)) end if end if newlen=reslen+len_trim(string)-fin+pos-1 if (eos > newlen) then if (istat==1) then string=string(1:(pos-1)) // & get_string(cdar(y)) // & string((fin+1):eos) else string=string(1:(pos-1)) // & trim(adjustl(cbuff)) // & string((fin+1):eos) end if pos=pos+reslen+2 else istat=-2 end if else istat=-1 end if else istat=-3 end if ! ! If failed substitution, close up variable in input string ! 999 continue if (istat < 0) then string=string(1:(pos-1)) // string((fin+1):eos) pos=pos-1 end if end subroutine get_var ! ! List Sib-pair accessible (atomic or pair) variables ! subroutine list_var(typ, ple) integer, intent(in) :: typ, ple integer :: i, obj, s, x, y character (len=1) :: ch character (len=20) :: string obj=oblist do while (obj /= nil) s=car(obj) x=envir do while (x /= nil) y=car(x) do while (y /= nil) if (caar(y) == s) then if (typ==1) then if (isstring(cdar(y))) then write(outstr, '(3a)') get_string(car(s)), '=', get_string(cdar(y)) else if (isnumber(cdar(y))) then write(string, '(i20)') get_ivalue(cdar(y)) write(outstr, '(3a)') get_string(car(s)), '=', adjustl(trim(string)) end if else if (ceqstr('*sp-fun*', car(cdar(y)))) then if (ple < 1) then write(outstr, '(a)') get_string(car(s)) else write(outstr, '(2a/a)', advance='no') & get_string(car(s)), ':', ' ' s=cdr(cdar(y)) do i=1, get_strlen(s) ch=get_substr(s, i-1, i) if (ch == ';') then write(outstr,'(/a)', advance='no') ' ' else write(outstr,'(a)', advance='no') ch end if end do write(outstr,*) end if end if exit end if y=cdr(y) end do if (y /= nil) exit x=cdr(x) end do obj=cdr(obj) end do end subroutine list_var ! ! Test if a macro function exists ! function isafun(nam) integer :: isafun character (len=*), intent(in) :: nam integer :: tmp, x, y isafun=0 tmp=oblist do while (tmp /= nil) if (ceqstr(trim(nam), caar(tmp))) exit tmp=cdr(tmp) end do if (tmp == nil) then return end if tmp=car(tmp) x=envir do while (x /= nil) y=car(x) do while (y /= nil) if (caar(y) == tmp) exit y=cdr(y) end do if (y /= nil) exit x=cdr(x) end do if (x /= nil) then if (ceqstr('*sp-fun*', car(cdar(y)))) then isafun=cdr(cdar(y)) end if end if end function isafun ! function procnum(p) integer :: procnum integer :: p procnum=mem(p)%value end function procnum function syntaxnum(p) integer :: syntaxnum integer :: p syntaxnum=mem(p)%keynum end function syntaxnum ! ! Underlying primitives for Scheme ! function typeof(p) integer :: typeof integer, intent(in) :: p typeof=mem(p)%iflag end function typeof function isstring(p) logical :: isstring integer, intent(in) :: p isstring=(iand(typeof(p), T_STRING) /= 0) end function isstring function isnumber(p) logical :: isnumber integer, intent(in) :: p isnumber=(iand(typeof(p), T_NUMBER) /= 0) end function isnumber function ispair(p) logical :: ispair integer, intent(in) :: p ispair=(iand(typeof(p), T_PAIR) /= 0) end function ispair ! ! car, cdr etc ! function car(p) integer :: car integer, intent(in) :: p car = mem(p)%car end function car function cdr(p) integer :: cdr integer, intent(in) :: p cdr = mem(p)%cdr end function cdr ! function caar(p) integer :: caar integer, intent(in) :: p caar = mem(p)%car caar = mem(caar)%car end function caar function cadr(p) integer :: cadr integer, intent(in) :: p cadr = mem(p)%cdr cadr = mem(cadr)%car end function cadr function cdar(p) integer :: cdar integer, intent(in) :: p cdar = mem(p)%car cdar = mem(cdar)%cdr end function cdar function cddr(p) integer :: cddr integer, intent(in) :: p cddr = mem(p)%cdr cddr = mem(cddr)%cdr end function cddr function cadar(p) integer :: cadar integer, intent(in) :: p cadar = mem(p)%car cadar = mem(cadar)%cdr cadar = mem(cadar)%car end function cadar function caddr(p) integer :: caddr integer, intent(in) :: p caddr = mem(p)%cdr caddr = mem(caddr)%cdr caddr = mem(caddr)%car end function caddr function cadaar(p) integer :: cadaar integer, intent(in) :: p cadaar = mem(p)%car cadaar = mem(cadaar)%car cadaar = mem(cadaar)%cdr cadaar = mem(cadaar)%car end function cadaar function cadddr(p) integer :: cadddr integer, intent(in) :: p cadddr = mem(p)%cdr cadddr = mem(cadddr)%cdr cadddr = mem(cadddr)%cdr cadddr = mem(cadddr)%car end function cadddr function cddddr(p) integer :: cddddr integer, intent(in) :: p cddddr = mem(p)%cdr cddddr = mem(cddddr)%cdr cddddr = mem(cddddr)%cdr cddddr = mem(cddddr)%cdr end function cddddr ! function issymbol(p) logical :: issymbol integer, intent(in) :: p issymbol=(iand(typeof(p), T_SYMBOL) /= 0) end function issymbol function issyntax(p) logical :: issyntax integer, intent(in) :: p issyntax=(iand(typeof(p), T_SYNTAX) /= 0) end function issyntax function isproc(p) logical :: isproc integer, intent(in) :: p isproc=(iand(typeof(p), T_PROC) /= 0) end function isproc function isclosure(p) logical :: isclosure integer, intent(in) :: p isclosure=(iand(typeof(p), T_CLOSURE) /= 0) end function isclosure function ismacro(p) logical :: ismacro integer, intent(in) :: p ismacro=(iand(typeof(p), T_MACRO) /= 0) end function ismacro function iscontinuation(p) logical :: iscontinuation integer, intent(in) :: p iscontinuation=(iand(typeof(p), T_CONTINUATION) /= 0) end function iscontinuation function ispromise(p) logical :: ispromise integer, intent(in) :: p ispromise=(iand(typeof(p), T_PROMISE) /= 0) end function ispromise function isport(p) logical :: isport integer, intent(in) :: p isport=(iand(typeof(p), T_PORT) /= 0) end function isport ! true or false value functions function istrue(p) logical :: istrue integer :: p istrue=(p /= nil .and. p /= f) end function istrue function isfalse(p) logical :: isfalse integer :: p isfalse=(p /= nil .and. p == f) end function isfalse ! ! tower of numbers ! function isinteger(p) logical :: isinteger integer :: p isinteger=(isnumber(p) .and. mem(p)%keynum == 1) end function isinteger function isfloat(p) logical :: isfloat integer :: p isfloat=(isnumber(p) .and. mem(p)%keynum == 2) end function isfloat ! ! Garbage collection ! function isatom(p) logical :: isatom integer, intent(in) :: p isatom=(iand(typeof(p), T_ATOM) /= 0) end function isatom subroutine setatom(p) integer, intent(in) :: p call set_type(p, ior(typeof(p), T_ATOM)) end subroutine setatom subroutine clratom(p) integer, intent(in) :: p call set_type(p, iand(typeof(p), T_CLRATOM)) end subroutine clratom function ismark(p) logical :: ismark integer, intent(in) :: p ismark=(iand(typeof(p), T_MARK) /= 0) end function ismark subroutine setmark(p) integer, intent(in) :: p call set_type(p, ior(typeof(p), T_MARK)) end subroutine setmark subroutine clrmark(p) integer, intent(in) :: p call set_type(p, iand(typeof(p), T_UNMARK)) end subroutine clrmark ! ! Cons ! function cons(reg1, reg2) integer cons integer :: reg1, reg2 cons=getcell(reg1, reg2) call set_type(cons, T_PAIR) mem(cons)%car = reg1 mem(cons)%cdr = reg2 end function cons ! ! Contents of a Lisp string cell equal to a Fortran string ! function ceqstr(cstr, reg) logical :: ceqstr character (len=*) :: cstr integer, intent(in) :: reg integer :: i ceqstr=.true. if (mem(reg)%slength /= len(cstr)) then ceqstr=.false. return else do i=1, len(cstr) if (cstr(i:i) /= mem(reg)%svalue(i)) then ceqstr=.false. return end if end do end if end function ceqstr ! ! Contents of a Lisp string equal to a Lisp string ! function streq(a, b) logical :: streq integer, intent(in) :: a, b integer :: i, slen streq=.true. slen=mem(a)%slength if (slen /= mem(b)%slength) then streq=.false. else do i=1, slen if (mem(a)%svalue(i) /= mem(b)%svalue(i)) then streq=.false. return end if end do end if end function streq ! ! Declare a number ! function mk_number(num) integer :: mk_number integer (kind=8), intent(in) :: num integer :: tmp tmp=getcell(nil, nil) call set_type(tmp, ior(T_NUMBER, T_ATOM)) call set_ivalue(tmp, num) mk_number=tmp end function mk_number ! ! Declare a real ! function mk_real(num) integer :: mk_real double precision, intent(in) :: num integer :: tmp tmp=getcell(nil, nil) call set_type(tmp, ior(T_NUMBER, T_ATOM)) call set_value(tmp, num) mk_real=tmp end function mk_real ! ! Declare a string ! function mk_string(nam) integer :: mk_string character (len=*), intent(in) :: nam integer :: tmp tmp=getcell(nil, nil) call set_type(tmp, ior(T_STRING, T_ATOM)) call set_string(tmp, nam) mk_string=tmp end function mk_string ! ! Declare a symbol ! function mk_symbol(nam) integer :: mk_symbol character (len=*), intent(in) :: nam integer :: tmp tmp=oblist do while (tmp /= nil) if (ceqstr(trim(nam), caar(tmp))) exit tmp=cdr(tmp) end do if (tmp /= nil) then mk_symbol=car(tmp) else tmp=cons(mk_string(nam), nil) call set_type(tmp, T_SYMBOL) oblist=cons(tmp, oblist) mk_symbol=tmp end if end function mk_symbol ! ! make symbol or number atom from string ! function mk_atom(str) use string_utilities integer :: mk_atom character (len=*), intent(in) :: str integer :: letpos, i, ich, slen integer (kind=8) :: x logical :: hasdot, isnum ! functions ! integer :: ival ! double precision :: fval slen=len(str) letpos=0 hasdot=.false. isnum=.true. do i=1, slen ich = ichar(str(i:i)) if (ich < 48 .or. ich > 57) then if ((ich == 43 .or. ich == 45) .and. & (i == 1 .or. i == (letpos+1)) .and. slen>1) then continue else if ((ich == 100 .or. ich == 101 .or. ich == 68 .or. & ich == 69) .and. letpos == 0 .and. i>1) then letpos=i else if (ich == 46 .and. .not.hasdot) then hasdot=.true. else isnum=.false. exit end if end if end do if (isnum) then if (hasdot .or. letpos>0) then mk_atom=mk_real(fval(str)) else read(str,'(i40)') x mk_atom=mk_number(x) end if else mk_atom=mk_symbol(str) end if end function mk_atom ! ! Make a constant ! function mk_const(nam) integer :: mk_const character (len=*) :: nam integer :: nchar integer (kind=8) :: x if (nam == 't') then mk_const=t else if (nam == 'f') then mk_const=f else if (nam(1:1) == 'b') then read(nam, '(1x,b20)') x mk_const=mk_number(x) else if (nam(1:1) == 'd') then read(nam, '(1x,i20)') x mk_const=mk_number(x) else if (nam(1:1) == 'o') then read(nam, '(1x,o20)') x mk_const=mk_number(x) else if (nam(1:1) == 'x') then read(nam, '(1x,z20)') x mk_const=mk_number(x) else if (nam(1:1) == '\') then nchar=len_trim(nam) if (nchar == 2) then mk_const=mk_string(nam(2:2)) else if (nam(2:nchar) == 'space') then mk_const=mk_string(' ') else if (nam(2:nchar) == 'newline') then mk_const=mk_string(char(12)) else if (nchar == 1) then mk_const=mk_string(' ') else mk_const=nil end if else mk_const=nil end if end function mk_const ! ! make closure, c is code, e is environment ! function mk_closure(c, e) integer :: mk_closure integer :: c, e integer :: x x=getcell(c, e) call set_type(x, T_CLOSURE) call set_car(x, c) call set_cdr(x, e) mk_closure=x end function mk_closure ! ! make continuation ! function mk_continuation(d) integer :: mk_continuation integer :: d integer :: x x=getcell(nil, d) call set_type(x, T_CONTINUATION) call set_cdr(x, d) mk_continuation=x end function mk_continuation ! ! make a port ! function mk_port(iport, nam) integer :: mk_port integer (kind=8), intent(in) :: iport character (len=*), intent(in) :: nam integer :: tmp tmp=getcell(nil, nil) call set_type(tmp, ior(T_PORT, T_ATOM)) call set_ivalue(tmp, iport) call set_string(tmp, nam) mk_port=tmp end function mk_port ! ! Test a port - return location in portaddress function test_port(iport) integer :: test_port integer, intent(in) :: iport integer :: i do i=1, nports if (portaddress(i) == iport) then test_port=i return end if end do test_port=0 end function test_port ! ! Reverse list ! function reverse(a) integer :: reverse integer, intent(in) :: a integer :: p, tmp integer :: i p=nil tmp=a i=0 do while (ispair(tmp)) i=i+1 p=cons(car(tmp), p) tmp=cdr(tmp) end do reverse=p end function reverse ! ! Reverse list -- no new cell generated ! function non_alloc_rev(term, list) integer :: non_alloc_rev integer, intent(in) :: term, list integer :: i, p, res, q i=0 p=list res=term do while (p /= nil) i=i+1 q=cdr(p) call set_cdr(p, res) res=p p=q end do non_alloc_rev=res end function non_alloc_rev ! ! append list -- make new cells ! function append(a, b) integer :: append integer, intent(in) :: a, b integer :: p, q, tmp p=b tmp=a if (tmp /= nil) then tmp = reverse(tmp) do while (tmp /= nil) q = cdr(tmp) call set_cdr(tmp, p) p = tmp tmp = q end do end if append=p end function append ! ! equivalence of atoms ! function eqv(a, b) logical :: eqv integer, intent(in) :: a, b eqv=.false. if (isstring(a)) then if (isstring(b)) then eqv=streq(a, b) end if else if (isnumber(a)) then if (isnumber(b)) then eqv=(get_ivalue(a) == get_ivalue(b)) end if else eqv=(a == b) end if end function eqv ! ! get a new character from input file or stdin ! subroutine inchar(ch) character (len=1) :: ch integer :: ios if (eol==0 .or. currentline > eol) then read(infp, '(a)', iostat=ios) scheme_lin if (ios /= 0 .and. infp /= STDIN) then write(outstr,'(3a)') 'Closing "', trim(loadfil), '".' close(infp, status='keep') infp=STDIN write(outstr, '(a)', advance='no') prompt_string read(infp, '(a)', iostat=ios) scheme_lin end if if (ios /= 0) then write(*, '(a)') 'Exiting!' return end if currentline=0 eol=len_trim(scheme_lin) end if currentline=currentline+1 if (currentline > eol) then ch=' ' else ch=scheme_lin(currentline:currentline) end if end subroutine inchar ! ! clear input buffer ! subroutine clearinput() currentline=eol end subroutine clearinput ! ! back to standard input ! subroutine flushinput() if (infp /= STDIN) then close(infp, status='keep') infp=STDIN end if call clearinput() end subroutine flushinput ! ! backstep one character in input buffer ! subroutine backchar() currentline=currentline-1 end subroutine backchar ! ! skip whitespace ! subroutine skipspace() do currentline=currentline+1 if (currentline > eol) exit if (scheme_lin(currentline:currentline)/=' ' .or. & scheme_lin(currentline:currentline)/=achar(9)) then exit end if end do currentline=currentline-1 end subroutine skipspace ! ! get next token ! function token() integer :: token character (len=1) :: ch integer :: ich do call skipspace() call inchar(ch) if (ch /= ' ' .and. ch /= achar(9)) exit end do ich = ichar(ch) if (ch == '(') then token=M_LPAREN else if (ch == ')') then token=M_RPAREN else if (ch == '.') then call inchar(ch) if (ch == ' ' .or. ch == achar(9) .or. ch == achar(10)) then token=M_DOT else call backchar() call backchar() token=M_ATOM end if else if (ich == 39) then token=M_QUOTE else if (ch == ';') then token=M_COMMENT else if (ch == '"') then token=M_DQUOTE else if (ch == '`') then token=M_BQUOTE else if (ch == ',') then call inchar(ch) if (ch == '@') then token=M_ATMARK else call backchar() token=M_COMMA end if else if (ch == '#') then token=M_SHARP else call backchar() token=M_ATOM end if end function token ! ! read characters to delimiter -- hard coded to work on Windows as well ! function scheme_delim(ch) logical :: scheme_delim character(len=1) :: ch integer :: ich ich=ichar(ch) scheme_delim=(ich == 9 .or. ich == 10 .or. & ich == 32 .or. ich== 40 .or. ich == 41) end function scheme_delim ! subroutine readstr(res) character (len=*) :: res integer :: pos, reslen character (len=1) :: ch reslen=len(res) res=' ' pos=0 rdloop: do call inchar(ch) if (currentline > eol) exit rdloop if (scheme_delim(ch)) exit rdloop pos=pos+1 if (pos <= reslen) res(pos:pos)=ch end do rdloop call backchar() end subroutine readstr ! ! read rest of a quoted string ! subroutine readstrexp(res, reslen) character (len=*) :: res character (len=1) :: ch integer, intent(out) :: reslen integer :: pos reslen=len(res) res=' ' pos=0 do call inchar(ch) #if defined (WIN32) || defined (IFORT) || defined (NOESCAPE) if (ch == '\') then #else if (ch == '\\') then #endif call inchar(ch) else if (ch == '"') then exit end if pos=pos+1 if (pos <= reslen) res(pos:pos)=ch end do reslen=min(pos, reslen) end subroutine readstrexp ! ! print an atom ! subroutine printatom(l,space) integer, intent(in) :: l, space character (len=20) :: str if (l == nil) then write(outfp, '(a)', advance='no') '()' else if (l == t) then write(outfp, '(a)', advance='no') '#t' else if (l == f) then write(outfp, '(a)', advance='no') '#f' else if (l == un) then continue else if (isnumber(l)) then if (isinteger(l)) then write(str, '(i20)') get_ivalue(l) else if (isfloat(l)) then write(str, '(g20.12)') get_value(l) end if call padprint(trim(adjustl(str)), space) else if (isstring(l)) then if (print_flag==1) then write(outfp,'(3a)',advance='no') '"', get_string(l), '"' else call padprint(get_string(l), space) end if else if (issymbol(l)) then write(outfp,'(a)',advance='no') get_string(car(l)) // ' ' else if (isproc(l)) then write(outfp,'(a,i0,a)', advance='no') '#' else if (ismacro(l)) then write(outfp,'(a)',advance='no') '#' else if (isclosure(l)) then write(outfp,'(a)',advance='no') '#' else if (iscontinuation(l)) then write(outfp,'(a)',advance='no') '#' else if (isport(l)) then write(outfp,'(a,i0,3a)',advance='no') '#' end if end subroutine printatom ! ! Pad printing of an atom ! subroutine padprint(str, space) character (len=*), intent(in) :: str integer, intent(in) :: space if (space < 0) then ilen=len(str) if (ilen < -space) then write(outfp, '(a)', advance='no') repeat(' ',-space-ilen) end if end if write(outfp, '(a)', advance='no') str if (space > 0) then ilen=len(str) if (ilen < space) then write(outfp, '(a)', advance='no') repeat(' ',space-ilen) end if end if end subroutine padprint ! function ok_abbrev(x) logical :: ok_abbrev integer :: x ok_abbrev=(ispair(x) .and. cdr(x) /= nil) end function ok_abbrev ! subroutine s_save(a, b, c) integer :: a, b, c dump = cons(envir, cons(c, dump)) dump = cons(b, dump) dump = cons(mk_number(int(a, kind=8)), dump) end subroutine s_save subroutine s_return(a) integer :: a value = a oper = get_ivalue(car(dump)) scm_args = cadr(dump) envir = caddr(dump) code = cadddr(dump) dump = cddddr(dump) end subroutine s_return subroutine s_retbool(tf) logical :: tf if (tf) then call s_return(t) else call s_return(f) end if end subroutine s_retbool ! ! Apply Scheme commands - split into opexe0 to opexe10 ! subroutine opexe0(op, inline) integer :: op integer :: inline integer :: x, y logical :: ios ! load if (op == OP_LOAD) then if (.not.isstring(car(scm_args))) then call error0('load -- argument is not string') return else loadfil=trim(get_string(car(scm_args))) inquire(file=trim(loadfil), exist=ios) if (.not.ios) then loadfil=' ' call error1('Unable to open', car(scm_args)) return else infp=LOADSTR open(infp, file=trim(loadfil), status='old') write(outstr, '(3a)') 'Loading "', trim(loadfil), '".' end if end if oper=OP_T0LVL ! top level else if (op == OP_T0LVL) then if (inline /= 3) write(outstr,*) dump = nil envir = global_env call s_save(OP_VALUEPRINT, nil, nil); call s_save(OP_T1LVL, nil, nil); if (inline == 1 .and. infp == STDIN) then write(*, '(a)', advance='no') prompt_string end if oper=OP_READ else if (op == OP_T1LVL) then code=value oper=OP_EVAL ! read else if (op == OP_READ) then tok=token() oper=OP_RDSEXPR ! print evaluation result else if (op == OP_VALUEPRINT) then print_flag=1 outfp=outstr scm_args=value call s_save(OP_T0LVL, nil, nil) oper=OP_P0LIST ! main part of evaluation else if (op == OP_EVAL) then ! symbol if (issymbol(code)) then x=envir do while (x /= nil) y=car(x) do while (y /= nil) if (caar(y) == code) exit y=cdr(y) end do if (y /= nil) exit x=cdr(x) end do if (x /= nil) then call s_return(cdar(y)) else call error1('Unbound variable', code) end if else if (ispair(code)) then ! syntax x = car(code) if (issyntax(x)) then code = cdr(code); oper=syntaxnum(x) ! first, eval top element and eval arguments else call s_save(OP_E0ARGS, nil, code) code = car(code) oper=OP_EVAL end if else call s_return(code) end if ! eval arguments else if (op == OP_E0ARGS) then if (ismacro(value)) then call s_save(OP_DOMACRO, nil, nil) args = cons(code, nil) code = value oper=OP_APPLY else code=cdr(code) oper=OP_E1ARGS end if else if (op == OP_E1ARGS) then scm_args=cons(value, scm_args) ! continue if (ispair(code)) then call s_save(OP_E1ARGS, scm_args, cdr(code)) code=car(code) scm_args=nil oper=OP_EVAL ! end else scm_args=reverse(scm_args) code=car(scm_args) scm_args=cdr(scm_args) oper=OP_APPLY end if ! apply code to args else if (op == OP_APPLY) then if (isproc(code)) then oper=procnum(code) else if (isclosure(code)) then envir= cons(nil, cdr(code)) x=car(car(code)) y=scm_args do while (ispair(x)) if (y == nil) then call error0('Too few arguments') return else call set_car(envir, cons(cons(car(x), car(y)), car(envir))) end if x=cdr(x) y=cdr(y) end do if (x == nil) then continue else if (issymbol(x)) then call set_car(envir, cons(cons(x,y), car(envir))) else call error0('Syntax error in closure') return end if code=cdar(code) scm_args=nil oper=OP_BEGIN ! continuation else if (iscontinuation(code)) then dump=cdr(code) if (scm_args /= nil) then call s_return(car(scm_args)) else call s_return(nil) end if else call error0('Illegal function') return end if ! do macro else if (op == OP_DOMACRO) then code=value oper=OP_EVAL ! lambda else if (op == OP_LAMBDA) then call s_return(mk_closure(code, envir)) ! quote else if (op == OP_QUOTE) then call s_return(car(code)) ! define else if (op == OP_DEF0) then if (ispair(car(code))) then x=caar(code) code=cons(lambda, cons(cdar(code), cdr(code))) else x=car(code) code=cadr(code) end if if (.not.issymbol(x)) then call error0('Variable is not symbol') return end if call s_save(OP_DEF1, nil, x) oper=OP_EVAL ! define else if (op == OP_DEF1) then x=car(envir) do while (x /= nil) if (caar(x) == code) exit x=cdr(x) end do if (x /= nil) then call set_cdar(x, value) else call set_car(envir, cons(cons(code, value), car(envir))) end if call s_return(code) ! set! else if (op == OP_SET0) then call s_save(OP_SET1, nil, car(code)) code=cadr(code) oper=OP_EVAL ! set! else if (op == OP_SET1) then x=envir do while (x /= nil) y=car(x) do while (y /= nil) if (caar(y) == code) exit y=cdr(y) end do if (y /= nil) exit x=cdr(x) end do if (x /= nil) then call set_cdar(y, value) call s_return(value) else call error1('Unbound variable', code) end if ! begin else if (op == OP_BEGIN) then if (.not.ispair(code)) then call s_return(code) end if if (cdr(code) /= nil) then call s_save(OP_BEGIN, nil, cdr(code)) end if code = car(code) oper=OP_EVAL ! if else if (op == OP_IF0) then call s_save(OP_IF1, nil, cdr(code)) code = car(code) oper=OP_EVAL else if (op == OP_IF1) then if (istrue(value)) then code=car(code) else code=cadr(code) end if oper=OP_EVAL ! let else if (op == OP_LET0) then scm_args=nil value=code if (issymbol(car(code))) then code=cadr(code) else code=car(code) end if oper=OP_LET1 ! let (calculate parameters) else if (op == OP_LET1) then scm_args=cons(value, scm_args) if (ispair(code)) then call s_save(OP_LET1, scm_args, cdr(code)) code=cadar(code) scm_args=nil oper=OP_EVAL else scm_args=reverse(scm_args) code=car(scm_args) scm_args=cdr(scm_args) oper=OP_LET2 end if else if (op == OP_LET2) then envir=cons(nil, envir) if (issymbol(car(code))) then x=cadr(code) else x=car(code) end if y=scm_args do while (y /= nil) call set_car(envir, cons(cons(caar(x), car(y)), car(envir))) x=cdr(x) y=cdr(y) end do ! named let if (issymbol(car(code))) then x=cadr(code) scm_args=nil do while (x /= nil) scm_args=cons(caar(x), scm_args) x=cdr(x) end do x=mk_closure(cons(reverse(scm_args), cddr(code)), envir) call set_car(envir, cons(cons(car(code), x), car(envir))) code=cddr(code) scm_args=nil else code=cdr(code) scm_args=nil end if oper=OP_BEGIN ! let* else if (op == OP_LET0AST) then if (car(code) == nil) then envir = cons(nil, envir) code=cdr(code) oper=OP_BEGIN end if call s_save(OP_LET1AST, cdr(code), car(code)) code=cadaar(code) oper=OP_EVAL ! let* (make new frame) else if (op == OP_LET1AST) then envir=cons(nil, envir) oper=OP_LET2AST ! let* (calculate parameters) else if (op == OP_LET2AST) then call set_car(envir, cons(cons(caar(code), value), car(envir))) code = cdr(code) ! continue if (ispair(code)) then call s_save(OP_LET2AST, scm_args, code) code = cadar(code) scm_args = nil oper=OP_EVAL ! end else code = scm_args scm_args = nil oper=OP_BEGIN end if else write(*, '(i3,a)') oper, ' is an illegal operator' end if end subroutine opexe0 subroutine opexe1(op) integer :: op integer :: x, y ! letrec if (op == OP_LET0REC) then envir = cons(nil, envir) scm_args = nil value = code code = car(code) oper=OP_LET1REC ! letrec calculate parameters else if (op == OP_LET1REC) then scm_args = cons(value, scm_args) if (ispair(code)) then ! continue call s_save(OP_LET1REC, scm_args, cdr(code)) code=cadar(code) scm_args=nil oper=OP_EVAL else ! end scm_args = reverse(scm_args) code = car(scm_args) scm_args = cdr(scm_args) oper=OP_LET2REC end if ! letrec else if (op == OP_LET2REC) then x=car(code) y=scm_args do while (y /= nil) call set_car(envir, cons(cons(caar(x), car(y)), car(envir))) x=cdr(x) y=cdr(y) end do code=cdr(code) scm_args=nil oper=OP_BEGIN ! cond else if (op == OP_COND0) then if (.not.ispair(code)) then call error0('Syntax error in cond') return end if call s_save(OP_COND1, nil, code) code=caar(code) oper=OP_EVAL else if (op == OP_COND1) then if (istrue(value)) then code= cdar(code) if (code == nil) then call s_return(value) end if oper=OP_BEGIN else code=cdr(code) if (code == nil) then call s_return(nil) else call s_save(OP_COND1, nil, code) code=caar(code) oper=OP_EVAL end if end if ! delay else if (op == OP_DELAY) then x=mk_closure(cons(nil, code), envir) call set_type(x, ior(T_PROMISE, typeof(x))) call s_return(x) ! and else if (op == OP_AND0) then if (code==nil) then call s_return(t) end if call s_save(OP_AND1, nil, cdr(code)) code=car(code) oper=OP_EVAL ! and else if (op == OP_AND1) then if (isfalse(value)) then call s_return(value) else if (code == nil) then call s_return(value) else call s_save(OP_AND1, nil, cdr(code)) code=car(code) oper=OP_EVAL end if ! or else if (op == OP_OR0) then if (code==nil) then call s_return(f) end if call s_save(OP_OR1, nil, cdr(code)) code=car(code) oper=OP_EVAL ! or else if (op == OP_OR1) then if (istrue(value)) then call s_return(value) else if (code == nil) then call s_return(value) else call s_save(OP_OR1, nil, cdr(code)) code=car(code) oper=OP_EVAL end if ! cons-stream else if (op == OP_C0STREAM) then call s_save(OP_C1STREAM, nil, cdr(code)) code=car(code) oper=OP_EVAL ! cons-stream else if (op == OP_C1STREAM) then scm_args=value x=mk_closure(cons(nil, code), envir) call set_type(x, ior(T_PROMISE, typeof(x))) call s_return(cons(scm_args, x)) ! macro else if (op == OP_0MACRO) then x = car(code) code = cadr(code) if (.not.issymbol(x)) then call error0('Variable is not symbol') end if call s_save(OP_1MACRO, nil, x) oper=OP_EVAL else if (op == OP_1MACRO) then call set_type(value, ior(T_MACRO, typeof(value))) x=car(envir) do while (x /= nil) if (caar(x) == code) exit x = cdr(x) end do if (x /= nil) then call set_cdar(x, value) else call set_car(envir, cons(cons(code, value), car(envir))) end if call s_return(code) ! case else if (op == OP_CASE0) then call s_save(OP_CASE1, nil, cdr(code)) code=car(code) oper=OP_EVAL ! case else if (op == OP_CASE1) then x=code do while (x /= nil) y=caar(x) if (.not.ispair(y)) then exit end if do while (y /= nil) if (eqv(car(y), value)) then exit end if y=cdr(y) end do if (y /= nil) exit x = cdr(x) end do if (x /= nil) then if (ispair(caar(x))) then code = cdar(x) oper=OP_BEGIN ! else else call s_save(OP_CASE2, nil, cdar(x)) code=caar(x) oper=OP_EVAL end if else call s_return(nil) end if ! case else if (op == OP_CASE2) then if (istrue(value)) then oper=OP_BEGIN else call s_return(nil) end if ! apply else if (op == OP_PAPPLY) then code=car(scm_args) scm_args=cadr(scm_args) oper=OP_APPLY ! eval else if (op == OP_PEVAL) then code=car(scm_args) scm_args=nil oper=OP_EVAL ! call-with-current-continuation else if (op == OP_CONTINUATION) then code=car(scm_args) scm_args=cons(mk_continuation(dump), nil) oper=OP_APPLY else write(outstr, '(2a)') oper, 'is an illegal operator!' end if end subroutine opexe1 ! subroutine opexe2(op) integer :: op integer :: x logical :: int_op integer (kind=8) :: d, i, v double precision :: rv int_op=.true. ! + if (op == OP_ADD) then x = scm_args v = 0 rv= 0.0 do while (x /= nil) if (.not.isnumber(car(x))) then call error1('Argument is not a number: ', car(x)) return else if (isfloat(car(x))) then if (int_op) then int_op=.false. rv=v end if rv=rv+get_value(car(x)) else if (int_op) then v=v+get_ivalue(car(x)) end if x=cdr(x) end do if (int_op) then call s_return(mk_number(v)) else call s_return(mk_real(rv)) end if ! - else if (op == OP_SUB) then x = cdr(scm_args) if (.not.isnumber(car(scm_args))) then call error1('Argument is not a number: ', car(scm_args)) return else if (isfloat(car(scm_args))) then int_op=.false. rv = get_value(car(scm_args)) else v = get_ivalue(car(scm_args)) end if i = 1 do while (x /= nil) i=i+1 if (.not.isnumber(car(x))) then call error1('Argument is not a number: ', car(x)) return else if (isfloat(car(x))) then if (int_op) then int_op=.false. rv=v end if rv=rv-get_value(car(x)) else if (int_op) then v=v-get_ivalue(car(x)) else rv=rv-dfloat(get_ivalue(car(x))) end if x=cdr(x) end do if (i==1) then if (int_op) then v=-v else rv=-rv end if end if if (int_op) then call s_return(mk_number(v)) else call s_return(mk_real(rv)) end if ! * else if (op == OP_MUL) then x = scm_args v = 1 rv = 1.0 do while (x /= nil) if (.not.isnumber(car(x))) then call error1('Argument is not a number: ', car(x)) return else if (isfloat(car(x))) then if (int_op) then int_op=.false. rv=v end if rv=rv*get_value(car(x)) else if (int_op) then v=v*get_ivalue(car(x)) else rv=rv*get_ivalue(car(x)) end if x=cdr(x) end do if (int_op) then call s_return(mk_number(v)) else call s_return(mk_real(rv)) end if ! / else if (op == OP_DIV) then x = cdr(scm_args) if (.not.isnumber(car(scm_args))) then call error1('Argument is not a number: ', car(scm_args)) return else rv = rvalue(car(scm_args)) end if if (x == nil) then rv=1.0d0/rv else do while (x /= nil) if (.not.isnumber(car(x))) then call error1('Argument is not a number: ', car(x)) return else if (get_value(car(x)) /= 0.0d0) then rv=rv/rvalue(car(x)) else call error0('Divided by zero!') return end if end if x=cdr(x) end do end if call s_return(mk_real(rv)) ! quotient else if (op == OP_INTDIV) then x = cdr(scm_args) if (.not.isnumber(car(scm_args))) then call error1('Argument is not a number: ', car(scm_args)) return else if (isfloat(car(scm_args))) then v = int(get_value(car(scm_args)), kind=8) else v = get_ivalue(car(scm_args)) end if do while (x /= nil) if (.not.isnumber(car(x))) then call error1('Argument is not a number: ', car(x)) return else if (isfloat(car(x))) then d=int(get_value(car(x)), kind=8) else d=get_ivalue(car(x)) end if if (d /= 0) then v=v/d else call error0('Divided by zero!') return end if x=cdr(x) end do call s_return(mk_number(v)) ! remainder else if (op == OP_REM) then x = cdr(scm_args) if (.not.isnumber(car(scm_args))) then call error1('Argument is not a number: ', car(scm_args)) return else if (isfloat(car(scm_args))) then int_op=.false. rv = get_value(car(scm_args)) else v = get_ivalue(car(scm_args)) end if do while (x /= nil) if (.not.isnumber(car(x))) then call error1('Argument is not a number: ', car(x)) return else if (isfloat(car(x))) then if (int_op) then int_op=.false. rv=v end if if (get_value(car(x)) /= 0) then rv=mod(rv, get_value(car(x))) else call error0('Divided by zero!') return end if else if (int_op) then if (get_ivalue(car(x)) /= 0) then v=mod(v, int(get_ivalue(car(x)), kind=8)) else call error0('Divided by zero!') return end if else if (get_ivalue(car(x)) /= 0) then rv=mod(rv, dble(get_ivalue(car(x)))) else call error0('Divided by zero!') return end if end if x=cdr(x) end do if (int_op) then call s_return(mk_number(v)) else call s_return(mk_real(rv)) end if ! modulo else if (op == OP_MOD) then if (isinteger(car(scm_args)) .and. isinteger(cadr(scm_args))) then i = get_ivalue(cadr(scm_args)) if (i /= 0) then v = mod(get_ivalue(car(scm_args)), i) if (v*i < 0) then i=abs(i) if (v > 0) then v=v-i else v=v+i end if end if call s_return(mk_number(v)) else call error0('Modulo x 0 not allowed!') end if else call error0('Arguments must be integer!') end if ! car else if (op == OP_CAR) then if (ispair(car(scm_args))) then call s_return(caar(scm_args)) else call error0('Unable to car for a non-cons cell!') end if ! cdr else if (op == OP_CDR) then if (ispair(car(scm_args))) then call s_return(cdar(scm_args)) else call error0('Unable to cdr for a non-cons cell!') end if ! cons else if (op == OP_CONS) then call set_cdr(scm_args, cadr(scm_args)) call s_return(scm_args) ! set-car! else if (op == OP_SETCAR) then if (ispair(car(scm_args))) then call set_caar(scm_args, cadr(scm_args)) call s_return(car(scm_args)) else call error0('Unable to set-car! for a non-cons cell!') end if ! set-cdr! else if (op == OP_SETCDR) then if (ispair(car(scm_args))) then call set_cdar(scm_args, cadr(scm_args)) call s_return(car(scm_args)) else call error0('Unable to set-cdr! for a non-cons cell!') end if else write(outstr, '(2a)') oper, 'is an illegal operator!' end if end subroutine opexe2 ! subroutine opexe3(op) integer :: op integer :: x integer (kind=8) :: v logical :: comp ! not if (op == OP_NOT) then call s_retbool(isfalse(car(scm_args))) ! boolean? else if (op == OP_BOOL) then call s_retbool(car(scm_args) == f .or. car(scm_args) == t) ! integer? else if (op == OP_ISINT) then call s_retbool(isinteger(car(scm_args))) ! real? else if (op == OP_ISREAL) then call s_retbool(isfloat(car(scm_args))) ! null else if (op == OP_NULL) then call s_retbool(car(scm_args) == nil) ! zero? else if (op == OP_ZEROP) then call s_retbool(get_ivalue(car(scm_args)) == 0) ! positive? else if (op == OP_POSP) then call s_retbool(get_ivalue(car(scm_args)) > 0) ! negative? else if (op == OP_NEGP) then call s_retbool(get_ivalue(car(scm_args)) < 0) ! =, <, >, <=, >= else if (op >= OP_NUMEQ .and. op <= OP_GEQ) then x = cdr(scm_args) if (.not.isnumber(car(scm_args))) then call error1('Argument is not a number: ', car(scm_args)) return else v = get_ivalue(car(scm_args)) end if do while (x /= nil) if (.not.isnumber(car(x))) then call error1('Argument is not a number: ', car(x)) return else if (op == OP_NUMEQ) then comp=(v==get_ivalue(car(x))) else if (op == OP_LESS) then comp=(vget_ivalue(car(x))) else if (op == OP_LEQ) then comp=(v<=get_ivalue(car(x))) else if (op == OP_GEQ) then comp=(v>=get_ivalue(car(x))) end if if (.not.comp) exit end if x=cdr(x) end do call s_retbool(comp) ! symbol? else if (op == OP_SYMBOL) then call s_retbool(issymbol(car(scm_args))) ! number? else if (op == OP_NUMBER) then call s_retbool(isnumber(car(scm_args))) ! string? else if (op == OP_STRING) then call s_retbool(isstring(car(scm_args))) ! procedure? else if (op == OP_PROC) then call s_retbool(isproc(car(scm_args)) .or. isclosure(car(scm_args)) .or. & iscontinuation(car(scm_args))) ! pair? else if (op == OP_PAIR) then call s_retbool(ispair(car(scm_args))) ! eq? else if (op == OP_EQ) then call s_retbool(car(scm_args) == cadr(scm_args)) ! eqv? else if (op == OP_EQV) then call s_retbool(eqv(car(scm_args),cadr(scm_args))) else write(outstr, '(2a)') oper, 'is an illegal operator!' end if end subroutine opexe3 ! subroutine opexe4(op, plevel) integer, intent(in) :: op integer, intent(in) :: plevel ! force if (op == OP_FORCE) then code = car(scm_args) if (ispromise(code)) then scm_args=nil oper=OP_APPLY else call s_return(code) end if ! write or display else if (op == OP_WRITE .or. op == OP_DISPLAY) then print_flag=0 if (op == OP_WRITE) print_flag=print_flag+1 outfp=outstr if (ispair(cdr(scm_args))) then if (isport(cadr(scm_args))) then outfp=get_ivalue(cadr(scm_args)) end if end if scm_args=car(scm_args) oper=OP_P0LIST ! newline else if (op == OP_NEWLINE) then outfp=outstr if (ispair(scm_args)) then if (isport(car(scm_args))) then outfp=get_ivalue(car(scm_args)) end if end if if (plevel >= 0) write(outfp,*) call s_return(un) ! error else if (op == OP_ERR0) then if (.not.isstring(car(scm_args))) then call error0('Error -- first argument must be a string') end if write(outstr, '(2a)', advance='no') 'Error: ', get_string(car(scm_args)) scm_args=cdr(scm_args) oper=OP_ERR1 ! error else if (op == OP_ERR1) then write(outstr, '(a)', advance='no') ' ' if (scm_args /= nil) then call s_save(OP_ERR1, cdr(scm_args), nil) scm_args=car(scm_args) print_flag=1 oper=OP_P0LIST else write(outstr,*) call flushinput() oper=OP_T0LVL end if ! reverse else if (op == OP_REVERSE) then if (.not.ispair(car(scm_args))) then call error0('argument of reverse must be a pair') return end if call s_return(reverse(car(scm_args))) ! append else if (op == OP_APPEND) then call s_return(append(car(scm_args), cadr(scm_args))) ! gc else if (op == OP_GC) then call gc(nil, nil, 1) call s_return(t) ! memory-allocate else if (op == OP_GCVERB) then if (.not.isnumber(car(scm_args))) then call error0('memory-allocate -- argument must be a number!') return end if call setup_mem(int(get_ivalue(car(scm_args)), kind=4)) call s_return(t) ! new segment size else if (op == OP_NEWSEGMENT) then if (.not.isnumber(car(scm_args))) then call error0('new segment -- argument must be a number!') return end if cell_segment=get_ivalue(car(scm_args)) write(outstr, '(a,i4,a)') & 'Allocation of new memory in increments of ', cell_segment, ' cells' call s_return(t) end if end subroutine opexe4 ! subroutine opexe5(op, plevel) integer, intent(in) :: op integer, intent(in) :: plevel integer :: x integer :: strlen character (len=5000) :: str character (len=1) :: ch if (op == OP_RDSEXPR) then if (tok == M_COMMENT) then do call inchar(ch) if (currentline > eol) exit end do tok = token() oper=OP_RDSEXPR else if (tok == M_LPAREN) then tok = token() if (tok == M_RPAREN) then call s_return(nil) else if (tok == M_DOT) then call error0('Syntax error -- illegal dot expression') else call s_save(OP_RDLIST, nil, nil) oper=OP_RDSEXPR end if else if (tok == M_QUOTE) then call s_save(OP_RDQUOTE, nil, nil) tok=token() oper=OP_RDSEXPR else if (tok == M_BQUOTE) then call s_save(OP_RDQQUOTE, nil, nil) tok=token() oper=OP_RDSEXPR else if (tok == M_COMMA) then call s_save(OP_RDUNQUOTE, nil, nil) tok=token() oper=OP_RDSEXPR else if (tok == M_ATMARK) then call s_save(OP_RDUQTSP, nil, nil) tok=token() oper=OP_RDSEXPR else if (tok == M_ATOM) then call readstr(str) call s_return(mk_atom(trim(str))) else if (tok == M_DQUOTE) then call readstrexp(str, strlen) call s_return(mk_string(str(1:strlen))) else if (tok == M_SHARP) then call readstr(str) x=mk_const(str) if (x == nil) then call error0('Undefined sharp expression') else call s_return(x) end if else call error0('syntax error -- illegal token') end if else if (op == OP_RDLIST) then scm_args = cons(value, scm_args) tok = token() if (tok == M_COMMENT) then do call inchar(ch) if (currentline > eol) exit end do tok = token() end if if (tok == M_RPAREN) then call s_return(non_alloc_rev(nil, scm_args) ) else if (tok == M_DOT) then call s_save(OP_RDDOT, scm_args, nil) tok=token() oper=OP_RDSEXPR else call s_save(OP_RDLIST, scm_args, nil) oper=OP_RDSEXPR end if else if (op == OP_RDDOT) then if (token() /= M_RPAREN) then call error0('syntax error -- illegal dot expression') end if call s_return(non_alloc_rev(value, scm_args)) else if (op == OP_RDQUOTE) then call s_return(cons(quote, cons(value, nil))) else if (op == OP_RDQQUOTE) then call s_return(cons(qquote, cons(value, nil))) else if (op == OP_RDUNQUOTE) then call s_return(cons(unquote, cons(value, nil))) else if (op == OP_RDUQTSP) then call s_return(cons(unquotesp, cons(value, nil))) else if (op == OP_P0LIST) then if (.not.ispair(scm_args)) then if (plevel >= 0) call printatom(scm_args,0) call s_return(un) else if (car(scm_args) == quote .and. ok_abbrev(cdr(scm_args))) then if (plevel >= 0) write(outfp, '(a)', advance='no') '"' scm_args=cadr(scm_args) oper=OP_P0LIST else if (car(scm_args) == qquote .and. ok_abbrev(cdr(scm_args))) then if (plevel >= 0) write(outfp, '(a)', advance='no') '`' scm_args=cadr(scm_args) oper=OP_P0LIST else if (car(scm_args) == unquote .and. ok_abbrev(cdr(scm_args))) then if (plevel >= 0) write(outfp, '(a)', advance='no') ',' scm_args=cadr(scm_args) oper=OP_P0LIST else if (car(scm_args) == unquotesp .and. ok_abbrev(cdr(scm_args))) then if (plevel >= 0) write(outfp, '(a)', advance='no') ',@' scm_args=cadr(scm_args) oper=OP_P0LIST else if (plevel >= 0) write(outfp, '(a)', advance='no') '(' call s_save(OP_P1LIST, cdr(scm_args), nil) scm_args=car(scm_args) oper=OP_P0LIST end if else if (op == OP_P1LIST) then if (ispair(scm_args)) then call s_save(OP_P1LIST, cdr(scm_args), nil) if (plevel >= 0) write(outfp, '(a)', advance='no') ' ' scm_args=car(scm_args) oper=OP_P0LIST else if (scm_args /= nil) then if (plevel >= 0) then write(outfp, '(a)', advance='no') ' . ' call printatom(scm_args,0) end if end if if (plevel >= 0) write(outfp, '(a)', advance='no') ')' call s_return(un) end if else write(outstr, '(2a)') oper, 'is an illegal operator!' end if end subroutine opexe5 ! subroutine opexe6(op) integer :: op integer :: w, x, y ! list-length if (op == OP_LIST_LENGTH) then w=get_listlen(car(scm_args)) if (w < 0) then call error1('Not a list:', car(scm_args)) else call s_return(mk_number(int(w, kind=8))) end if ! assq else if (op == OP_ASSQ) then x=car(scm_args) y=cadr(scm_args) do while (ispair(y)) if (.not.ispair(car(y))) then call error0('Unable to handle non-pair element') return end if if (x == caar(y)) exit y=cdr(y) end do if (ispair(y)) then call s_return(car(y)) else call s_return(f) end if ! get-closure-code else if (op == OP_GET_CLOSURE) then scm_args=car(scm_args) if (scm_args == nil) then call s_return(f) else if (isclosure(scm_args)) then call s_return(cons(lambda, car(value))) else if (ismacro(scm_args)) then call s_return(cons(lambda, car(value))) else call s_return(f) end if ! closure? else if (op == OP_CLOSUREP) then if (car(scm_args) == nil) then call s_return(f) end if call s_retbool(isclosure(car(scm_args))) ! macro? else if (op == OP_MACROP) then if (car(scm_args) == nil) then call s_return(f) end if call s_retbool(ismacro(car(scm_args))) else write(outstr, '(2a)') oper, 'is an illegal operator!' end if end subroutine opexe6 ! ! Mathematical functions ! subroutine opexe7(op) integer :: op integer :: x, y integer (kind=8) :: v double precision :: rv ! exponentiation if (op == OP_EXP) then x = car(scm_args) rv=exp(rvalue(x)) call s_return(mk_real(rv)) ! natural log else if (op == OP_LOG) then x = car(scm_args) rv = log(rvalue(x)) call s_return(mk_real(rv)) ! sine else if (op == OP_SIN) then x = car(scm_args) rv = sin(rvalue(x)) call s_return(mk_real(rv)) ! cosine else if (op == OP_COS) then x = car(scm_args) rv = cos(rvalue(x)) call s_return(mk_real(rv)) ! tan else if (op == OP_TAN) then x = car(scm_args) rv = tan(rvalue(x)) call s_return(mk_real(rv)) ! arcsine else if (op == OP_ASIN) then x = car(scm_args) rv = asin(rvalue(x)) call s_return(mk_real(rv)) ! arcosine else if (op == OP_ACOS) then x = car(scm_args) rv = acos(rvalue(x)) call s_return(mk_real(rv)) ! arctan else if (op == OP_ATAN) then x = car(scm_args) rv = atan(rvalue(x)) call s_return(mk_real(rv)) ! sqrt else if (op == OP_SQRT) then x = car(scm_args) rv = sqrt(rvalue(x)) call s_return(mk_real(rv)) ! truncate else if (op == OP_TRUNCATE) then x = car(scm_args) rv = int(rvalue(x)) call s_return(mk_real(rv)) ! round else if (op == OP_ROUND) then x = car(scm_args) rv = anint(rvalue(x)) call s_return(mk_real(rv)) ! abs else if (op == OP_ABS) then x = car(scm_args) if (isinteger(x)) then v=abs(get_ivalue(x)) call s_return(mk_number(v)) else rv = abs(rvalue(x)) call s_return(mk_real(rv)) end if else if (op == OP_EXPT) then x = car(scm_args) y = cadr(scm_args) if (isinteger(x) .and. isinteger(y) .and. get_ivalue(y) >= 0) then v = get_ivalue(x) ** get_ivalue(y) call s_return(mk_number(v)) else rv = rvalue(x) ** rvalue(y) call s_return(mk_real(rv)) end if end if end subroutine opexe7 ! ! A few other library functions eg min, max ! subroutine opexe8(op) use rngs integer :: op integer :: x logical :: int_op integer (kind=8) :: v double precision :: rv int_op=.true. ! min if (op == OP_MIN) then if (isnumber(car(scm_args))) then int_op=isinteger(car(scm_args)) if (int_op) then v=get_ivalue(car(scm_args)) else rv=get_value(car(scm_args)) end if x = cdr(scm_args) do while (x /= nil) if (isfloat(car(x))) then if (int_op) then int_op=.false. end if rv=min(rv,rvalue(car(x))) else if (int_op) then v=min(v,get_ivalue(car(x))) else rv=min(rv,rvalue(car(x))) end if x=cdr(x) end do if (int_op) then call s_return(mk_number(v)) else call s_return(mk_real(rv)) end if else call error0('Min needs at least one argument!') end if ! max else if (op == OP_MAX) then if (isnumber(car(scm_args))) then int_op=isinteger(car(scm_args)) if (int_op) then v=get_ivalue(car(scm_args)) else rv=get_value(car(scm_args)) end if x = cdr(scm_args) do while (x /= nil) if (isfloat(car(x))) then if (int_op) then int_op=.false. end if rv=max(rv,rvalue(car(x))) else if (int_op) then v=max(v,get_ivalue(car(x))) else rv=max(rv,rvalue(car(x))) end if x=cdr(x) end do if (int_op) then call s_return(mk_number(v)) else call s_return(mk_real(rv)) end if else call error0('Max needs at least one argument!') end if ! random else if (op == OP_RANDOM) then if (isnumber(car(scm_args))) then v=get_ivalue(car(scm_args)) call s_return(mk_number(int(irandom(1, int(v, kind=4)), kind=8))) else call s_return(mk_real(dble(random()))) end if end if end subroutine opexe8 ! ! string functions ! subroutine opexe9(op) integer :: op integer :: i, ioerr, j, l, v, x logical :: comp, inword, intresult double precision :: rv character (len=1) :: ch, sep character (len=20) :: str character (len=200) :: bigstr ch=' ' ! make-string if (op == OP_MKSTRING) then l=get_ivalue(car(scm_args)) if (cdr(scm_args) /= nil) then ch=get_substr(cadr(scm_args), 0, 1) end if call s_return(mk_string(repeat(ch,l))) ! string-length else if (op == OP_STRLEN) then call s_return(mk_number(int(get_strlen(car(scm_args)), kind=8))) ! string-set! else if (op == OP_STRSET) then i=get_ivalue(cadr(scm_args)) if (i > get_strlen(car(scm_args))) then call error1('ERROR: string-set! out of bounds:', cadr(scm_args)) return end if call set_substring(car(scm_args), i, i, get_substr(caddr(scm_args), 0, 1)) call s_return(car(scm_args)) ! substring else if (op == OP_SUBSTR) then l=get_strlen(car(scm_args)) i=get_ivalue(cadr(scm_args)) if (i > l) then call error1('substring start out of bounds:', cadr(scm_args)) return end if if (cddr(scm_args) /= nil) then j=get_ivalue(caddr(scm_args)) if (j > l) then call error1('substring end out of bounds:', caddr(scm_args)) return end if else j=l end if call s_return(mk_string(get_substr(car(scm_args), i, j))) ! string-append else if (op == OP_STRAPPEND) then l=0 x=scm_args do while (x /= nil) l=l+get_strlen(car(x)) x=cdr(x) end do v=mk_string(repeat(' ',l)) i=0 l=0 x=scm_args do while (x /= nil) l=l+get_strlen(car(x)) call set_substring(v, i+1, l, get_string(car(x))) i=l x=cdr(x) end do call s_return(v) ! string-split else if (op == OP_STRSPLIT) then v=car(scm_args) l=get_strlen(v) sep=' ' seplen=1 inword=.false. if (cdr(scm_args) /= nil) then sep=get_string(cadr(scm_args)) seplen=get_strlen(cadr(scm_args)) inword=.true. end if x=nil if (seplen == 0) then do i=1, l x=cons(mk_string(get_substr(v, i-1, i)), x) end do else j=1 do i=1, l ch=get_substr(v, i-1, i) if (ch == sep .or. (sep == ' ' .and. ichar(ch) == 9)) then if (inword) then x=cons(mk_string(get_substr(v, j-1, i-1)), x) if (sep /= ' ') then j=i+1 else inword=.false. end if end if else if (.not.inword) then inword=.true. j=i end if end if end do if (inword) x=cons(mk_string(get_substr(v, j-1, l)), x) end if call s_return(reverse(x)) ! string=?, string?, string<=?, string>=?, substring? else if (op >= OP_STREQ .and. op <= OP_STRGE) then x = cdr(scm_args) if (.not.isstring(car(scm_args))) then call error1('Argument is not a string: ', car(scm_args)) return else bigstr=get_string(car(scm_args)) end if do while (x /= nil) if (.not.isstring(car(x))) then call error1('Argument is not a string: ', car(x)) return else if (op == OP_STREQ) then comp=(bigstr==get_string(car(x))) else if (op == OP_STRLT) then comp=(bigstrget_string(car(x))) else if (op == OP_STRLE) then comp=(bigstr<=get_string(car(x))) else if (op == OP_STRGE) then comp=(bigstr>=get_string(car(x))) end if if (.not.comp) exit end if x=cdr(x) end do call s_retbool(comp) ! substring? else if (op == OP_STRFIND) then if (.not.isstring(car(scm_args))) then call error1('Argument is not a string: ', car(scm_args)) return else if (.not.isstring(cadr(scm_args))) then call error1('Argument is not a string: ', cadr(scm_args)) return end if i=index(get_string(cadr(scm_args)), get_string(car(scm_args))) if (i == 0) then call s_return(f) else call s_return(mk_number(int(i-1, kind=8))) end if ! char->integer else if (op == OP_CHAR2INT) then if (.not.isstring(car(scm_args))) then call error1('Argument is not a string: ', car(scm_args)) return end if str=get_string(car(scm_args)) i = ichar(str(1:1)) call s_return(mk_number(int(i,kind=8))) ! integer->char else if (op == OP_INT2CHAR) then i=get_ivalue(car(scm_args)) call s_return(mk_string(char(i))) ! string->number else if (op == OP_STR2NUM) then if (.not.isstring(car(scm_args))) then call error1('Argument is not a string: ', car(scm_args)) return end if j=10 intresult=.true. str=get_string(car(scm_args)) if (cdr(scm_args) /= nil) then j=get_ivalue(cadr(scm_args)) end if if (j == 2) then read(str,'(b20)', iostat=ioerr) i else if (j == 8) then read(str,'(o20)', iostat=ioerr) i else if (j == 16) then read(str,'(z20)', iostat=ioerr) i else read(str,'(i20)', iostat=ioerr) i if (ioerr /= 0) then intresult=.false. read(str,'(f20.0)', iostat=ioerr) rv end if end if if (ioerr /= 0) then call s_return(f) else if (intresult) then call s_return(mk_number(int(i,kind=8))) else call s_return(mk_real(rv)) end if ! number->string else if (op == OP_NUM2STR) then x=car(scm_args) if (isnumber(x)) then if (isinteger(x)) then write(str,'(i20)') get_ivalue(x) else write(str,'(g20.12)') get_value(x) end if call s_return(mk_string(trim(adjustl(str)))) else call s_return(f) end if ! string->symbol else if (op == OP_STR2SYM) then call s_return(mk_symbol(get_string(car(scm_args)))) ! symbol->string else if (op == OP_SYM2STR) then call s_return(mk_string(get_string(caar(scm_args)))) end if end subroutine opexe9 ! ! Nonstandard library additions for system interface such as system, read-line ! subroutine opexe10(op, plevel) use string_utilities integer :: op integer, intent(in) :: plevel integer, parameter :: MISS = -9999 integer :: i, imod, ioerr, j, l, n, tmp, typ, v, x logical :: filexist, ios character (len=1) :: ch character (len=20) :: str character (len=256) :: buff ! functions ! logical :: strfind #if IFORT || SUN character (len=24) :: fdate #endif ! system command from within scheme str=' ' if (op == OP_SYSTEM) then if (.not.isstring(car(scm_args))) then call error0('Error -- first argument must be a string') call s_return(f) else call system(get_string(car(scm_args))) call s_return(t) end if else if (op == OP_IPORT .or. op == OP_OPORT) then if (isstring(car(scm_args))) then buff=get_string(car(scm_args)) end if if (plevel >= 0) then write(outstr, '(3a)') '# Opening "', trim(buff), '"' end if inquire(file=trim(buff), exist=filexist) if (.not.filexist .and. op == OP_IPORT) then call error0('Cannot open "' // trim(buff) //'"!') call s_return(f) else if (nports < MAXPORT) then nports=nports+1 iport=portaddress(nports) inquire(iport, opened=ios) if (ios) close(iport, status='keep') open(iport, file=trim(buff), status='unknown', iostat=ioerr) if (ioerr /= 0) then call error0('ERROR: Cannot open "' // trim(buff) // '"!') call s_return(f) else call s_return(mk_port(int(iport, kind=8), trim(buff))) end if else call error0('Too many open files!') call s_return(f) end if else if (op == OP_CLPORT) then if (isport(car(scm_args))) then iport=get_ivalue(car(scm_args)) j=test_port(iport) if (j > 0) then close(iport) tmp=portaddress(nports) portaddress(nports)=portaddress(j) portaddress(j)=tmp nports=nports-1 call set_ivalue(car(scm_args), 0_8) call s_return(t) else call error0('Closed port!') call s_return(f) end if else call error0('Not a port!') call s_return(f) end if else if (op == OP_CURR_INPORT) then call s_return(mk_number(int(infp, kind=8))) else if (op == OP_CURR_OUTPORT) then call s_return(mk_number(int(outstr, kind=8))) else if (op == OP_RDLINE) then if (car(scm_args) == nil) then i=mk_string('') do read(*, '(a)', advance='no', iostat=ioerr) buff if (ioerr == -2) then call append_string(i, trim(buff)) call s_return(i) exit else if (ioerr /= 0) then call s_return(f) exit else call append_string(i, buff) end if end do else if (isport(car(scm_args))) then iport=get_ivalue(car(scm_args)) j=test_port(iport) if (j > 0) then i=mk_string('') do read(iport, '(a)', advance='no', iostat=ioerr) buff if (ioerr == -2) then call append_string(i, trim(buff)) call s_return(i) exit else if (ioerr /= 0) then call s_return(f) exit else call append_string(i, buff) end if end do else call error0('Closed port!') call s_return(f) end if else call error0('Not a port!') call s_return(f) end if ! internal simple format else if (op == OP_FORMAT) then typ=car(scm_args) if (((typ == t .or. typ == f .or. isport(typ)) .and. & isstring(cadr(scm_args))) .or. isstring(typ)) then outfp=outstr if (isport(typ)) outfp=get_ivalue(typ) if (isstring(typ)) then buff=get_string(typ) l=get_strlen(typ) typ=t x = cdr(scm_args) else buff=get_string(cadr(scm_args)) l=get_strlen(cadr(scm_args)) x = cddr(scm_args) end if ! scan the format string and match up to arguments i=1 do while (i <= l) ch=buff(i:i) if (ch=='~' .and. i= 48 .and. ich <= 57) then j=i do while (j <= l .and. ich >= 48 .and. ich <= 57) j=j+1 ch=buff(j:j) ich=ichar(ch) end do write(str, '(a,i0,a)') '(i', j-i+1, ')' read(buff(i:(j-1)),str) n if (j > l) exit i=j end if ! if "@", this is a modifier, eg affecting padding if (ch == '@' .and. i] args...!') end if call s_return(un) ! run a Sib-pair command else if (op == OP_RUNCMD) then l=0 x=scm_args do while (x /= nil) if (isnumber(car(x))) then write(str, '(i20)') get_ivalue(car(x)) str=adjustl(str) l=l+len_trim(str)+1 else l=l+get_strlen(car(x))+1 end if x=cdr(x) end do v=mk_string(repeat(' ',l)) i=0 l=0 x=scm_args do while (x /= nil) if (isnumber(car(x))) then write(str, '(i20)') get_ivalue(car(x)) str=adjustl(str) l=l+len_trim(str) call set_substring(v, i+1, l, trim(str)) else l=l+get_strlen(car(x)) call set_substring(v, i+1, l, get_string(car(x))) end if l=l+1 i=l call set_substring(v, i, i, ';') x=cdr(x) end do commands=get_string(v) // trim(commands) if (ilevel /= 0) ilevold=ilevel ilevel=0 call s_return(t) ! fdate, getenv else if (op == OP_FDATE) then call s_return(mk_string(trim(fdate()))) else if (op == OP_GETENV) then call getenv(get_string(car(scm_args)), buff) call s_return(mk_string(trim(buff))) else if (op == OP_INQUIRE) then inquire(file=get_string(car(scm_args)), exist=ios) call s_retbool(ios) ! Scheme specific help else if (op == OP_APROPOS) then str=' ' if (isstring(car(scm_args))) then str='*' // trim(get_string(car(scm_args))) // '*' end if tmp=oblist do while (tmp /= nil) if (strfind(trim(str), get_string(caar(tmp)), 1)) then write(outstr, '(a)') get_string(caar(tmp)) end if tmp=cdr(tmp) end do call s_return(t) else if (op == OP_HELP) then write(outstr, '(a)') & 'Sib-pair Scheme is a minimal scheme interpreter.', & 'It implements integer/fixnum arithmetic and strings.', & '(apropos ) lists commands containing that string.', & '(file-exists? ) test file.', & '(open-input-file ) open a port.', & '(close-input-port ) close a port.', & '(read-line []) reads in next line from stdin or open file.', & '(format "{~[:num:][@][ASD~%]}" ...) formatted output.', & '(string-split []) splits string on white space or optional char.', & '(substring? ) returns start of substring in string.', & '(seq ) generate sequence.', & '(system ) passes command to shell.', & '(getenv ) returns value of environment variable.', & '(date) returns current date and time.', & '(run ...) runs a Sib-pair command.', & '(pass-command ...) stores Sib-pair commands to the buffer', & 'for evaluation once you return to the usual Sib-pair prompt.' write(outstr, '(a)') & 'Statistical procedures include:', & ' (pnorm ) (qnorm

) (fp )', & ' (pchisq []) (qchisq

)', & ' (bivnor ) (pgamma

) (lgamma )' call s_return(un) end if end subroutine opexe10 ! ! Statistical library ! subroutine opexe11(op) use statfuns integer :: op integer :: ifault, x, y, z integer (kind=8) :: v double precision :: rv ! gaussian if (op == OP_PNORM) then if (isnumber(car(scm_args))) then rv=zp(rvalue(car(scm_args))) call s_return(mk_real(rv)) else call error0('pnorm needs a numerical argument!') end if else if (op == OP_QNORM) then x = car(scm_args) if (isnumber(x)) then rv=ppnd(1.0d0-rvalue(x)) call s_return(mk_real(rv)) else call error0('qnorm needs a numerical argument!') end if ! chi-square else if (op == OP_PCHISQ) then x = car(scm_args) y = cadr(scm_args) z = caddr(scm_args) if (isnumber(x) .and. isnumber(y) .and. get_ivalue(y) > 0) then if (isnumber(z)) then rv=1.0d0-chi2nc(rvalue(x), rvalue(y), rvalue(z), ifault) else rv=chip(rvalue(x), int(rvalue(y))) end if call s_return(mk_real(rv)) else call error0('pchisq needs at least two numerical arguments!') end if else if (op == OP_QCHISQ) then x = car(scm_args) y = cadr(scm_args) if (isnumber(x) .and. isnumber(y) .and. get_ivalue(y) > 0) then rv=chisqd(rvalue(x), int(rvalue(y))) call s_return(mk_real(rv)) else call error0('qchisq needs two numerical arguments!') end if ! F-distribution else if (op == OP_PFDIST) then x = car(scm_args) y = cadr(scm_args) z = caddr(scm_args) if (isnumber(x) .and. isnumber(y) .and. isnumber(z)) then rv=fp(rvalue(x), int(rvalue(y)), int(rvalue(z))) call s_return(mk_real(rv)) else call error0('pf needs F, df1, df2!') end if ! bivariate gaussian else if (op == OP_BIVNOR) then x = car(scm_args) y = cadr(scm_args) z = caddr(scm_args) if (isnumber(x) .and. isnumber(y) .and. isnumber(z)) then rv=mvbvu(rvalue(x), rvalue(y), rvalue(z)) call s_return(mk_real(rv)) else call error0('bivnor needs p1, p2 and r!') end if ! gamma else if (op == OP_GAMMAD) then x = car(scm_args) y = cadr(scm_args) if (isnumber(x) .and. isnumber(y)) then rv=gammad(rvalue(x), rvalue(y), ifault) call s_return(mk_real(rv)) else call error0('pgamma needs two numerical arguments!') end if else if (op == OP_ALNGAM) then x = car(scm_args) if (isnumber(x)) then rv=alngam(rvalue(x), ifault) call s_return(mk_real(rv)) else call error0('lgamma needs a numerical argument!') end if end if end subroutine opexe11 ! ! GUI library (japi) ! #if JAPI subroutine opexe12(op) use japi integer :: op integer :: i, j, k, l, typ, v, w, x, y, z logical :: lstat character(len=256) :: buff1, buff2 i=0 if (op == OP_JSTART) then if (j_start()) then call s_return(t) else call s_return(f) end if else if (op == OP_JQUIT) then call j_quit() call s_return(t) else if (op == OP_JFRAME) then x = car(scm_args) if (isstring(x)) then i=j_frame(get_string(x)) else i=j_frame(' ') end if call s_return(mk_number(int(i, kind=8))) else if (op == OP_JPANEL) then x = car(scm_args) if (isnumber(x)) then i=j_panel(int(get_ivalue(x),kind=4)) else call error0('j_panel needs a frame handle!') end if call s_return(mk_number(int(i, kind=8))) else if (op == OP_JBORDERPANEL) then x = car(scm_args) y = car(scm_args) typ=0 if (isnumber(x)) then if (isnumber(y)) then typ=get_ivalue(y) else if (isstring(y)) then if (get_string(y) == 'linedown') then typ=j_linedown else if (get_string(y) == 'lineup') then typ=j_lineup else if (get_string(y) == 'areadown') then typ=j_areadown else if (get_string(y) == 'areaup') then typ=j_areaup end if end if i=j_borderpanel(int(get_ivalue(x), kind=4), int(typ, kind=4)) else call error0('j_borderpanel needs a frame handle and optional style!') end if call s_return(mk_number(int(i, kind=8))) else if (op == OP_JDIALOG) then x = car(scm_args) y = cadr(scm_args) if (isnumber(x)) then if (isstring(y)) then i=j_dialog(int(get_ivalue(x),kind=4), get_string(y)) else i=j_dialog(int(get_ivalue(x),kind=4), ' ') end if call s_return(mk_number(int(i, kind=8))) else call error0('j_dialog needs a frame handle!') end if else if (op == OP_JBUTTON) then x = car(scm_args) y = cadr(scm_args) if (isnumber(x)) then if (isstring(y)) then i=j_button(int(get_ivalue(x),kind=4), get_string(y)) else i=j_button(int(get_ivalue(x),kind=4), ' ') end if call s_return(mk_number(int(i, kind=8))) else call error0('j_button needs a frame handle!') end if else if (op == OP_JRADIOBUTTON) then x = car(scm_args) y = cadr(scm_args) if (isnumber(x)) then if (isstring(y)) then i=j_radiobutton(int(get_ivalue(x),kind=4), get_string(y)) else i=j_radiobutton(int(get_ivalue(x),kind=4), ' ') end if call s_return(mk_number(int(i, kind=8))) else call error0('j_radiobutton needs a handle!') end if else if (op == OP_JRADIOGROUP) then x = car(scm_args) if (isnumber(x)) then i=j_radiogroup(int(get_ivalue(x),kind=4)) call s_return(mk_number(int(i, kind=8))) else call error0('j_radiogroup needs a frame handle!') end if else if (op == OP_JCHECKBOX) then x = car(scm_args) y = cadr(scm_args) if (isnumber(x)) then if (isstring(y)) then i=j_checkbox(int(get_ivalue(x),kind=4), get_string(y)) else i=j_checkbox(int(get_ivalue(x),kind=4), ' ') end if call s_return(mk_number(int(i, kind=8))) else call error0('j_checkbox needs a frame handle!') end if else if (op == OP_JLIST) then x = car(scm_args) y = car(scm_args) if (isnumber(x) .and. isnumber(y)) then i=j_list(int(get_ivalue(x),kind=4), & int(get_ivalue(y),kind=4)) call s_return(mk_number(int(i, kind=8))) else call error0('j_list needs an object handle and number of rows!') end if else if (op == OP_JADD) then x = car(scm_args) y = car(scm_args) if (isnumber(x) .and. isnumber(y)) then call j_add(int(get_ivalue(x),kind=4), & int(get_ivalue(y),kind=4)) call s_return(t) else call error0('j_list needs an object handle and number of rows!') end if else if (op == OP_JSETCOLOR .or. op == OP_JSETCOLORBG) then x = car(scm_args) w = car(scm_args) y = car(scm_args) z = car(scm_args) if (isnumber(x) .and. isnumber(w) .and. & isnumber(y) .and. isnumber(z)) then if (op == OP_JSETCOLOR) then call j_setcolor(int(get_ivalue(x),kind=4), & int(get_ivalue(w),kind=4), & int(get_ivalue(y),kind=4), & int(get_ivalue(z),kind=4)) else call j_setcolorbg(int(get_ivalue(x),kind=4), & int(get_ivalue(w),kind=4), & int(get_ivalue(y),kind=4), & int(get_ivalue(z),kind=4)) end if call s_return(un) else call error0('j_setcolor needs handle, R, G, B!') end if else if (op == OP_JSETNAMEDCOLORBG) then x = car(scm_args) y = car(scm_args) if (isnumber(x) .and. isnumber(y)) then call j_setnamedcolorbg(int(get_ivalue(x),kind=4), & int(get_ivalue(y),kind=4)) call s_return(un) else call error0('j_setnamedcolorbg needs an object handle and color (0-7)!') end if else if (op == OP_JGETSELECT) then x = car(scm_args) if (isnumber(x)) then i=j_getselect(int(get_ivalue(x),kind=4)) call s_return(mk_number(int(i, kind=8))) else call error0('j_getselect needs a list or choice handle!') end if else if (op == OP_JSELECT .or. op == OP_JDESELECT) then x = car(scm_args) y = car(scm_args) if (isnumber(x) .and. isnumber(y)) then if (op == OP_JSELECT) then call j_select(int(get_ivalue(x),kind=4), & int(get_ivalue(y),kind=4)) else call j_deselect(int(get_ivalue(x),kind=4), & int(get_ivalue(y),kind=4)) end if call s_return(un) else call error0('j_deselect needs a list handle and item!') end if else if (op == OP_JFILESELECT .or. op == OP_JFILEDIALOG) then x = car(scm_args) w = cadr(scm_args) y = caddr(scm_args) z = cadddr(scm_args) if (isnumber(x) .and. isstring(w) .and. & isstring(y) .and. isstring(z)) then buff1=get_string(y) buff2=get_string(z) if (op == OP_JFILESELECT) then call j_fileselect(int(get_ivalue(x),kind=4), get_string(y), & buff1, buff2) else call j_filedialog(int(get_ivalue(x),kind=4), get_string(y), & buff1, buff2) end if x=nil x=cons(mk_string(trim(buff1)), x) x=cons(mk_string(trim(buff2)), x) call s_return(reverse(x)) else call error0('j_fileselect needs handle, title, filter, filename!') end if else if (op == OP_JENABLE) then x = car(scm_args) if (isnumber(x)) then call j_enable(int(get_ivalue(x),kind=4)) call s_return(un) else call error0('j_enable needs an object handle!') end if else if (op == OP_JDISABLE) then x = car(scm_args) if (isnumber(x)) then call j_disable(int(get_ivalue(x),kind=4)) call s_return(un) else call error0('j_disable needs an object handle!') end if else if (op == OP_JADDITEM) then x = car(scm_args) y = cadr(scm_args) if (isnumber(x) .and. isstring(y)) then call j_additem(int(get_ivalue(x),kind=4), get_string(y)) call s_return(un) else call error0('j_additem needs an object handle and string to be added!') end if else if (op == OP_JSEPERATOR) then x = car(scm_args) if (isnumber(x)) then call j_seperator(int(get_ivalue(x),kind=4)) call s_return(un) else call error0('j_seperator needs an object handle!') end if else if (op == OP_JTEXTFIELD) then x = car(scm_args) y = car(scm_args) if (isnumber(x) .and. isnumber(y)) then i=j_textfield(int(get_ivalue(x),kind=4), int(get_ivalue(y),kind=4)) call s_return(mk_number(int(i, kind=8))) else call error0('j_textfield needs an object handle and width!') end if else if (op == OP_JTEXTAREA) then x = car(scm_args) y = car(scm_args) z = car(scm_args) if (isnumber(x) .and. isnumber(y) .and. isnumber(z)) then i=j_textarea(int(get_ivalue(x),kind=4), & int(get_ivalue(y),kind=4), & int(get_ivalue(z),kind=4)) call s_return(mk_number(int(i, kind=8))) else call error0('j_textarea needs an object handle, nrows, ncols !') end if else if (op == OP_JSETBORDERPOS) then x = car(scm_args) y = cadr(scm_args) typ=1 if (isnumber(x)) then if (isnumber(y)) then typ=get_ivalue(y) else if (isstring(y)) then typ=aligntype(get_string(y)) end if call j_setborderpos(int(get_ivalue(x),kind=4), & int(typ, kind=4)) call s_return(un) else call error0('j_setborderpos needs text/grid handle and direction!') end if else if (op == OP_JSETROWS .or. op == OP_JSETCOLUMNS) then x = car(scm_args) y = cadr(scm_args) if (isnumber(x) .and. isnumber(y)) then if (op == OP_JSETROWS) then call j_setrows(int(get_ivalue(x),kind=4), & int(get_ivalue(y),kind=4)) else call j_setcolumns(int(get_ivalue(x),kind=4), & int(get_ivalue(y),kind=4)) end if call s_return(un) else call error0('j_setrows/columns needs text/grid handle and NR/NC!') end if else if (op == OP_JGETROWS .or. op == OP_JGETCOLUMNS) then x = car(scm_args) if (isnumber(x)) then if (op == OP_JGETROWS) then i=j_getrows(int(get_ivalue(x),kind=4)) else i=j_getcolumns(int(get_ivalue(x),kind=4)) end if call s_return(mk_number(int(i, kind=8))) else call error0('j_getrows/columns needs a text handle!') end if else if (op == OP_JGETLENGTH) then x = car(scm_args) if (isnumber(x)) then i=j_getlength(int(get_ivalue(x),kind=4)) call s_return(mk_number(int(i, kind=8))) else call error0('j_getlength needs a text handle!') end if else if (op == OP_JGETSELSTART .or. op == OP_JGETSELEND) then x = car(scm_args) if (isnumber(x)) then if (op == OP_JGETSELSTART) then i=j_getselstart(int(get_ivalue(x),kind=4)) else i=j_getselend(int(get_ivalue(x),kind=4)) end if call s_return(mk_number(int(i, kind=8))) else call error0('j_getselstart/end needs a text handle!') end if else if (op == OP_JSELECTTEXT) then x = car(scm_args) y = cadr(scm_args) z = caddr(scm_args) if (isnumber(x) .and. isnumber(y) .and. isnumber(z)) then call j_selecttext(int(get_ivalue(x),kind=4), & int(get_ivalue(y),kind=4), & int(get_ivalue(z),kind=4)) call s_return(un) else call error0('j_settext needs textarea handle, text, pos!') end if else if (op == OP_JGETTEXT .or. op == OP_JGETSELTEXT) then x = car(scm_args) if (isnumber(x)) then if (op == OP_JGETTEXT) then call j_gettext(int(get_ivalue(x),kind=4), buff1) else call j_getseltext(int(get_ivalue(x),kind=4), buff1) end if call s_return(mk_string(trim(buff1))) else call error0('j_gettext needs text handle!') end if else if (op == OP_JGETITEM) then x = car(scm_args) y = cadr(scm_args) if (isnumber(x) .and. isnumber(y)) then call j_getitem(int(get_ivalue(x),kind=4), & int(get_ivalue(y),kind=4), buff1) call s_return(mk_string(trim(buff1))) else call error0('j_getitem needs handle, item!') end if else if (op == OP_JLABEL) then x = car(scm_args) y = cadr(scm_args) if (isnumber(x)) then if (isstring(y)) then i=j_button(int(get_ivalue(x),kind=4), get_string(y)) else i=j_button(int(get_ivalue(x),kind=4), ' ') end if call s_return(mk_number(int(i, kind=8))) else call error0('j_label needs an object handle!') end if else if (op == OP_JGETCURPOS) then x = car(scm_args) if (isnumber(x)) then i=j_getcurpos(int(get_ivalue(x),kind=4)) else call error0('j_getitem needs an object handle!') end if call s_return(mk_number(int(i, kind=8))) else if (op == OP_JSETCURPOS) then x = car(scm_args) y = cadr(scm_args) if (isnumber(x) .and. isnumber(y)) then call j_setcurpos(int(get_ivalue(x),kind=4), & int(get_ivalue(y),kind=4)) call s_return(un) else call error0('j_setcurpos needs handle and pos!') call s_return(f) end if else if (op == OP_JSETFONT) then x = car(scm_args) w = cadr(scm_args) y = caddr(scm_args) z = cadddr(scm_args) typ=0 if (isnumber(x) .and. (isnumber(w) .or. isstring(w)) .and. & (isnumber(y) .or. isstring(y)) .and. isnumber(z)) then if (isnumber(w)) then typ=get_ivalue(w) else typ=fonttype(get_string(w)) end if if (isnumber(y)) then k=get_ivalue(y) else k=fonttype(get_string(y)) end if call j_setfont(int(get_ivalue(x), kind=4), & int(typ, kind=4), & int(k, kind=4), & int(get_ivalue(z), kind=4)) call s_return(un) else call error0('j_setfont needs handle, name, style, size!') end if else if (op == OP_JSETTEXT) then x = car(scm_args) y = cadr(scm_args) if (isnumber(x) .and. isstring(y)) then call j_settext(int(get_ivalue(x),kind=4), get_string(y)) call s_return(un) else call error0('j_settext needs handle and string!') end if else if (op == OP_JINSERTTEXT) then x = car(scm_args) y = cadr(scm_args) z = caddr(scm_args) if (isnumber(x) .and. isstring(y) .and. isnumber(z)) then call j_inserttext(int(get_ivalue(x),kind=4), & get_string(y), & int(get_ivalue(z),kind=4)) call s_return(un) else call error0('j_settext needs textarea handle, text, pos!') end if else if (op == OP_JREPLACETEXT) then x = car(scm_args) w = cadr(scm_args) y = caddr(scm_args) z = cadddr(scm_args) if (isnumber(x) .and. isstring(w) .and. & isnumber(y) .and. isnumber(z)) then call j_replacetext(int(get_ivalue(x),kind=4), & get_string(w), & int(get_ivalue(y),kind=4), & int(get_ivalue(z),kind=4)) call s_return(un) else call error0('j_replacetext needs textarea handle, text, start, end!') end if else if (op == OP_JDELETE) then x = car(scm_args) y = cadr(scm_args) z = caddr(scm_args) if (isnumber(x) .and. isnumber(y) .and. isnumber(z)) then call j_delete(int(get_ivalue(x),kind=4), & int(get_ivalue(y),kind=4), & int(get_ivalue(z),kind=4)) call s_return(un) else call error0('j_delete needs textarea handle, start, end!') end if else if (op == OP_JDISPOSE) then x = car(scm_args) if (isnumber(x)) then call j_dispose(int(get_ivalue(x),kind=4)) call s_return(t) else call error0('j_dispose needs a handle!') end if else if (op == OP_JMENUBAR) then x = car(scm_args) if (isnumber(x)) then i=j_menubar(int(get_ivalue(x),kind=4)) call s_return(mk_number(int(i, kind=8))) else call error0('j_menubar needs a frame handle!') end if else if (op == OP_JMENU) then x = car(scm_args) y = cadr(scm_args) if (isnumber(x)) then if (isstring(y)) then i=j_menu(int(get_ivalue(x),kind=4), get_string(y)) else i=j_menu(int(get_ivalue(x),kind=4), ' ') end if call s_return(mk_number(int(i, kind=8))) else call error0('j_menu needs an object handle!') end if else if (op == OP_JMENUITEM) then x = car(scm_args) y = cadr(scm_args) if (isnumber(x)) then if (isstring(y)) then i=j_menuitem(int(get_ivalue(x),kind=4), get_string(y)) else i=j_menuitem(int(get_ivalue(x),kind=4), ' ') end if call s_return(mk_number(int(i, kind=8))) else call error0('j_menuitem needs a menubar handle!') end if else if (op == OP_JPACK) then x = car(scm_args) if (isnumber(x)) then call j_pack(get_ivalue(x)) call s_return(un) else call error0('j_pack needs an object handle!') end if else if (op == OP_JSHOW) then x = car(scm_args) if (isnumber(x)) then call j_show(int(get_ivalue(x),kind=4)) call s_return(un) else call error0('j_show needs an object handle!') end if else if (op == OP_JHIDE) then x = car(scm_args) if (isnumber(x)) then call j_hide(int(get_ivalue(x),kind=4)) call s_return(un) else call error0('j_hide needs an object handle!') end if else if (op == OP_JKEYLISTENER) then x = car(scm_args) if (isnumber(x)) then i=j_keylistener(int(get_ivalue(x),kind=4)) call s_return(mk_number(int(i, kind=8))) else call error0('j_hide needs an object handle!') end if else if (op == OP_JGETKEYCODE) then x = car(scm_args) if (isnumber(x)) then i=j_getkeycode(int(get_ivalue(x),kind=4)) call s_return(mk_number(int(i, kind=8))) else call error0('j_getkeycode needs an object handle!') end if else if (op == OP_JGETKEYCHAR) then x = car(scm_args) if (isnumber(x)) then i=j_getkeychar(int(get_ivalue(x),kind=4)) call s_return(mk_number(int(i, kind=8))) else call error0('j_getkeychar needs an object handle!') end if else if (op == OP_JMOUSELISTENER) then x = car(scm_args) y = cadr(scm_args) typ = j_doubleclick if (isnumber(x)) then if (isstring(y)) then buff1=get_string(y) if (buff1 == 'entered') then typ=j_entererd else if (buff1 == 'moved') then typ=j_moved else if (buff1 == 'exited') then typ=j_exited else if (buff1 == 'pressed') then typ=j_pressed else if (buff1 == 'dragged') then typ=j_dragged else if (buff1 == 'released') then typ=j_released else if (buff1 == 'doubleclicked') then typ=j_doubleclick end if else if (isnumber(x)) then typ=get_ivalue(x) if (typ < j_moved .or. typ > j_doubleclicked) typ=j_doubleclick end if i=j_mouselistener(int(get_ivalue(x), kind=4), int(typ, kind=4)) call s_return(mk_number(int(i, kind=8))) else call error0('j_mouselistener needs an object handle!') end if else if (op == OP_JGETMOUSEBUTTON) then x = car(scm_args) if (isnumber(x)) then i=j_getmousebutton(int(get_ivalue(x),kind=4)) else call error0('j_getmousebutton needs an object handle!') end if call s_return(mk_number(int(i, kind=8))) else if (op == OP_JNEXTACTION) then i=j_nextaction() call s_return(mk_number(int(i, kind=8))) else if (op == OP_JGETWIDTH) then x = car(scm_args) if (isnumber(x)) then i=j_getwidth(int(get_ivalue(x),kind=4)) else call error0('j_getwidth needs an object handle!') end if call s_return(mk_number(int(i, kind=8))) else if (op == OP_JGETHEIGHT) then x = car(scm_args) if (isnumber(x)) then i=j_getheight(int(get_ivalue(x),kind=4)) else call error0('j_getheight needs an object handle!') end if call s_return(mk_number(int(i, kind=8))) else if (op == OP_JGETPOS) then x = car(scm_args) if (isnumber(x)) then call j_getpos(int(get_ivalue(x),kind=4), i, j) x=nil x=cons(mk_number(int(i,kind=8)), x) x=cons(mk_number(int(j,kind=8)), x) call s_return(reverse(x)) else call error0('j_getpos needs an object handle!') end if else if (op == OP_JSETPOS .or. op == OP_SETSIZE) then x = car(scm_args) y = cadr(scm_args) z = caddr(scm_args) if (isnumber(x) .and. isnumber(y) .and. isnumber(z)) then if (op == OP_JSETPOS) then call j_setpos(int(get_ivalue(x),kind=4), & int(get_ivalue(y),kind=4), & int(get_ivalue(z),kind=4)) else call j_setsize(int(get_ivalue(x),kind=4), & int(get_ivalue(y),kind=4), & int(get_ivalue(z),kind=4)) end if call s_return(t) else call error0('j_setpos/size needs handle, x and y coordinates!') end if else if (op == OP_JSETALIGN) then x = car(scm_args) y = cadr(scm_args) typ=1 if (isnumber(x)) then if (isnumber(y)) then typ=get_ivalue(y) else if (isstring(y)) then typ=aligntype(get_string(y)) end if call j_setalign(int(get_ivalue(x), kind=4), & int(typ, kind=4)) call s_return(un) else call error0('j_setalign needs handle, direction!') end if else if (op == OP_JSETBORDERLAYOUT) then x = car(scm_args) if (isnumber(x)) then call j_setborderlayout(int(get_ivalue(x),kind=4)) call s_return(t) else call error0('j_setborderlayout needs handle!') end if else if (op == OP_JSETGRIDLAYOUT) then x = car(scm_args) y = cadr(scm_args) z = caddr(scm_args) if (isnumber(x) .and. isnumber(y) .and. isnumber(z)) then call j_setgridlayout(int(get_ivalue(x),kind=4), & int(get_ivalue(y),kind=4), & int(get_ivalue(z),kind=4)) call s_return(t) else call error0('j_setgridlayout needs handle, NR, NC !') end if else if (op == OP_JSETFLOWLAYOUT) then x = car(scm_args) typ = j_vertical if (isnumber(x)) then if (isnumber(y)) then typ=get_ivalue(x) else if (isstring(y)) then if (get_string(y) == 'vertical') then typ=j_vertical else typ=j_horizontal end if end if call j_setflowlayout(int(get_ivalue(x), kind=4), & int(typ, kind=4)) call s_return(t) else call error0('j_setflowlayout needs handle and alignment!') end if end if end subroutine opexe12 #endif ! ! Initialization of internal keywords ! subroutine mk_syntax(op, nam) integer :: op character (len=*) :: nam integer :: x x=cons(mk_string(nam), nil) call set_type(x, ior(T_SYNTAX, T_SYMBOL)) call set_syntaxnum(x, op) oblist=cons(x, oblist) end subroutine mk_syntax ! subroutine mk_proc(op, nam) integer :: op character (len=*) :: nam integer :: x, y x=mk_symbol(nam) y=getcell(nil, nil) call set_type(y, ior(T_PROC, T_ATOM)) call set_ivalue(y, int(op, kind=8)) call set_car(global_env, cons(cons(x, y), car(global_env))) end subroutine mk_proc ! ! Initiate global environment ! subroutine init_vars_global() integer :: x infp=STDIN outp=STDOUT global_env=cons(nil, nil) x=mk_symbol('else') call set_car(global_env, cons(cons(x, t), car(global_env))) end subroutine init_vars_global ! ! Initiate syntax ! subroutine init_syntax() call mk_syntax(OP_LAMBDA, 'lambda') call mk_syntax(OP_QUOTE, 'quote') call mk_syntax(OP_DEF0, 'define') call mk_syntax(OP_IF0, 'if') call mk_syntax(OP_BEGIN, 'begin') call mk_syntax(OP_SET0, 'set!') call mk_syntax(OP_LET0, 'let') call mk_syntax(OP_LET0AST, 'let*') call mk_syntax(OP_LET0REC, 'letrec') call mk_syntax(OP_COND0, 'cond') call mk_syntax(OP_DELAY, 'delay') call mk_syntax(OP_AND0, 'and') call mk_syntax(OP_OR0, 'or') call mk_syntax(OP_C0STREAM, 'cons-stream') call mk_syntax(OP_0MACRO, 'macro') call mk_syntax(OP_CASE0, 'case') end subroutine init_syntax ! ! Initiate procedures ! subroutine init_procs() call mk_proc(OP_PEVAL, 'eval') call mk_proc(OP_PAPPLY, 'apply') call mk_proc(OP_CONTINUATION, 'call-with-current-continuation') call mk_proc(OP_FORCE, 'force') call mk_proc(OP_CAR, 'car') call mk_proc(OP_CDR, 'cdr') call mk_proc(OP_CONS, 'cons') call mk_proc(OP_SETCAR, 'set-car!') call mk_proc(OP_SETCDR, 'set-cdr!') call mk_proc(OP_ADD, '+') call mk_proc(OP_SUB, '-') call mk_proc(OP_MUL, '*') call mk_proc(OP_DIV, '/') call mk_proc(OP_INTDIV, 'quotient') call mk_proc(OP_REM, 'remainder') call mk_proc(OP_MOD, 'modulo') call mk_proc(OP_NOT, 'not') call mk_proc(OP_BOOL, 'boolean?') call mk_proc(OP_ISINT, 'integer?') call mk_proc(OP_ISREAL, 'real?') call mk_proc(OP_SYMBOL, 'symbol?') call mk_proc(OP_NUMBER, 'number?') call mk_proc(OP_STRING, 'string?') call mk_proc(OP_PROC, 'procedure?') call mk_proc(OP_PAIR, 'pair?') call mk_proc(OP_EQV, 'eqv?') call mk_proc(OP_EQ, 'eq?') call mk_proc(OP_NULL, 'null?') call mk_proc(OP_ZEROP, 'zero?') call mk_proc(OP_POSP, 'positive?') call mk_proc(OP_NEGP, 'negative?') call mk_proc(OP_NUMEQ, '=') call mk_proc(OP_LESS, '<') call mk_proc(OP_GRE, '>') call mk_proc(OP_LEQ, '<=') call mk_proc(OP_GEQ, '>=') call mk_proc(OP_READ, 'read') call mk_proc(OP_WRITE, 'write') call mk_proc(OP_DISPLAY, 'display') call mk_proc(OP_NEWLINE, 'newline') call mk_proc(OP_LOAD, 'load') call mk_proc(OP_ERR0, 'error') call mk_proc(OP_REVERSE, 'reverse') call mk_proc(OP_APPEND, 'append') call mk_proc(OP_GC, 'gc') call mk_proc(OP_GCVERB, 'memory-allocate') call mk_proc(OP_NEWSEGMENT, 'new-segment') call mk_proc(OP_LIST_LENGTH, 'length') call mk_proc(OP_ASSQ, 'assq') call mk_proc(OP_GET_CLOSURE, 'get-closure-code') call mk_proc(OP_CLOSUREP, 'closure?') call mk_proc(OP_MACROP, 'macro?') call mk_proc(OP_QUIT, 'quit') call mk_proc(OP_EXP, 'exp') call mk_proc(OP_LOG, 'log') call mk_proc(OP_SIN, 'sin') call mk_proc(OP_COS, 'cos') call mk_proc(OP_TAN, 'tan') call mk_proc(OP_ASIN, 'asin') call mk_proc(OP_ACOS, 'acos') call mk_proc(OP_ATAN, 'atan') call mk_proc(OP_SQRT, 'sqrt') call mk_proc(OP_TRUNCATE, 'truncate') call mk_proc(OP_ROUND, 'round') call mk_proc(OP_ABS, 'abs') call mk_proc(OP_EXPT, 'expt') call mk_proc(OP_MIN, 'min') call mk_proc(OP_MAX, 'max') call mk_proc(OP_RANDOM, 'random') call mk_proc(OP_MKSTRING, 'make-string') call mk_proc(OP_STRLEN, 'string-length') call mk_proc(OP_STRSET, 'string-set!') call mk_proc(OP_SUBSTR, 'substring') call mk_proc(OP_STRAPPEND, 'string-append') call mk_proc(OP_STRSPLIT, 'string-split') call mk_proc(OP_STREQ, 'string=?') call mk_proc(OP_STRLT, 'string?') call mk_proc(OP_STRLE, 'string<=?') call mk_proc(OP_STRGE, 'string>=?') call mk_proc(OP_STRFIND, 'substring?') call mk_proc(OP_CHAR2INT, 'char->integer') call mk_proc(OP_INT2CHAR, 'integer->char') call mk_proc(OP_STR2NUM, 'string->number') call mk_proc(OP_NUM2STR, 'number->string') call mk_proc(OP_STR2SYM, 'string->symbol') call mk_proc(OP_SYM2STR, 'symbol->string') call mk_proc(OP_SYSTEM, 'system') call mk_proc(OP_IPORT, 'open-input-file') call mk_proc(OP_CLPORT, 'close-input-port') call mk_proc(OP_OPORT, 'open-output-file') call mk_proc(OP_CLPORT, 'close-output-port') call mk_proc(OP_CURR_INPORT, 'current-input-port') call mk_proc(OP_CURR_OUTPORT, 'current-output-port') call mk_proc(OP_RDLINE, 'read-line') call mk_proc(OP_FORMAT, 'format') call mk_proc(OP_FDATE, 'date') call mk_proc(OP_GETENV, 'getenv') call mk_proc(OP_INQUIRE, 'file-exists?') call mk_proc(OP_APROPOS, 'apropos') call mk_proc(OP_HELP, 'help') ! Statistical procedures call mk_proc(OP_PNORM, 'pnorm') call mk_proc(OP_QNORM, 'qnorm') call mk_proc(OP_PCHISQ, 'pchisq') call mk_proc(OP_QCHISQ, 'qchisq') call mk_proc(OP_PFDIST, 'pf') call mk_proc(OP_BIVNOR, 'bivnor') call mk_proc(OP_GAMMAD, 'pgamma') call mk_proc(OP_ALNGAM, 'lgamma') end subroutine init_procs ! ! Inlined init.scm ! subroutine init_scm() scheme_lin='(define nil #f) (define t #t)' call repl_scheme(3,0) scheme_lin='(define (caar x) (car (car x)))' call repl_scheme(3,0) scheme_lin='(define (cadr x) (car (cdr x)))' call repl_scheme(3,0) scheme_lin='(define (cdar x) (cdr (car x)))' call repl_scheme(3,0) scheme_lin='(define (cddr x) (cdr (cdr x)))' call repl_scheme(3,0) scheme_lin='(define (caaar x) (car (car (car x))))' call repl_scheme(3,0) scheme_lin='(define (caadr x) (car (car (cdr x))))' call repl_scheme(3,0) scheme_lin='(define (cadar x) (car (cdr (car x))))' call repl_scheme(3,0) scheme_lin='(define (caddr x) (car (cdr (cdr x))))' call repl_scheme(3,0) scheme_lin='(define (cdaar x) (cdr (car (car x))))' call repl_scheme(3,0) scheme_lin='(define (cdadr x) (cdr (car (cdr x))))' call repl_scheme(3,0) scheme_lin='(define (cddar x) (cdr (cdr (car x))))' call repl_scheme(3,0) scheme_lin='(define (cdddr x) (cdr (cdr (cdr x))))' call repl_scheme(3,0) scheme_lin='(define call/cc call-with-current-continuation)' call repl_scheme(3,0) scheme_lin='(define (list . x) x)' call repl_scheme(3,0) ! scheme_lin='(define (map proc list) (if (pair? list) (cons (proc (car list)) (map proc (cdr list)))))' scheme_lin='(define (unzip1-with-cdr . lists) ' // & '(unzip1-with-cdr-iterative lists ' // char(39) // '()' // & char(39) // '()))' call repl_scheme(3,0) scheme_lin='(define (unzip1-with-cdr-iterative lists cars cdrs) ' // & '(if (null? lists) (cons cars cdrs) ' // & '(let ((car1 (caar lists)) (cdr1 (cdar lists)))' // & '(unzip1-with-cdr-iterative (cdr lists) ' // & ' (append cars (list car1)) (append cdrs (list cdr1))))))' call repl_scheme(3,0) scheme_lin='(define (map proc . lists) (if (null? lists) (apply proc)' // & '(if (null? (car lists)) ' // char(39) // '() ' // & '(let* ((unz (apply unzip1-with-cdr lists)) (cars (car unz)) ' // & '(cdrs (cdr unz))) (cons (apply proc cars) ' // & '(apply map (cons proc cdrs)))))))' call repl_scheme(3,0) scheme_lin='(define (for-each proc list) (if (pair? list) (begin (proc (car list)) (for-each proc (cdr list))) #t ))' call repl_scheme(3,0) scheme_lin='(define (list-tail x k) (if (zero? k) x (list-tail (cdr x) (- k 1))))' call repl_scheme(3,0) scheme_lin='(define (list-ref x k) (if (null? x) x (car (list-tail x k))))' call repl_scheme(3,0) scheme_lin='(define (atom? x) (not (pair? x)))' call repl_scheme(3,0) scheme_lin='(define (string->list x) (string-split x ""))' call repl_scheme(3,0) scheme_lin='(define (memq obj lst) (cond ((null? lst) #f) ((eq? obj (car lst)) lst) (else (memq obj (cdr lst)))))' call repl_scheme(3,0) scheme_lin='(define (equal? x y) (if (pair? x) (and (pair? y)' // & '(equal? (car x) (car y)) (equal? (cdr x) (cdr y)))' // & '(and (not (pair? y)) (eqv? x y))))' call repl_scheme(3,0) scheme_lin='(define (even? x) (if (integer? x) (zero? (remainder x 2))))' call repl_scheme(3,0) scheme_lin='(define (odd? x) (if (integer? x) (= (remainder x 2) 1)))' call repl_scheme(3,0) scheme_lin='(define (gcd a b) (let ((aa (abs a)) (bb (abs b)))' // & '(if (= bb 0) aa (gcd bb (remainder aa bb)))))' call repl_scheme(3,0) scheme_lin='(define (lcm a b) (if (or (= a 0) (= b 0)) 0 ' // & '(abs (* (quotient a (gcd a b)) b))))' call repl_scheme(3,0) scheme_lin='(define (generic-member cmp obj lst) (cond ((null? lst) #f)' // & '((cmp obj (car lst)) lst)' // & '(else (generic-member cmp obj (cdr lst)))))' call repl_scheme(3,0) scheme_lin='(define (memq obj lst) (generic-member eq? obj lst))' call repl_scheme(3,0) scheme_lin='(define (memv obj lst) (generic-member eqv? obj lst))' call repl_scheme(3,0) scheme_lin='(define (member obj lst) (generic-member equal? obj lst))' call repl_scheme(3,0) scheme_lin='(define (generic-assoc cmp obj alst)' // & '(cond ((null? alst) #f) ((cmp obj (caar alst))' // & '(car alst)) (else (generic-assoc cmp obj (cdr alst)))))' call repl_scheme(3,0) scheme_lin='(define (assq obj alst) (generic-assoc eq? obj alst))' call repl_scheme(3,0) scheme_lin='(define (assv obj alst) (generic-assoc eqv? obj alst))' call repl_scheme(3,0) scheme_lin='(define (assoc obj alst) (generic-assoc equal? obj alst))' call repl_scheme(3,0) scheme_lin='(define (seq m n) (if (> m n) ''() (cons m (seq (+ 1 m) n))))' call repl_scheme(3,0) end subroutine init_scm ! ! Initiate procedures ! subroutine init_globals() call init_vars_global() call init_syntax() call init_procs() ! init global pointers to special symbols lambda=mk_symbol('lambda') quote=mk_symbol('quote') qquote=mk_symbol('quasiquote') unquote=mk_symbol('unquote') unquotesp=mk_symbol('unquote-splicing') call init_scm() end subroutine init_globals ! ! Error handling ! subroutine error0(s) character (len=*) :: s scm_args=cons(mk_string(s), nil) oper=OP_ERR0 write(*,'(/5a)') ' At: "', scheme_lin(1:currentline), '^', & trim(scheme_lin(currentline+1:eol)) , '"' write(*,'(8x,a)') s end subroutine error0 ! subroutine error1(s, a) integer :: a character (len=*) :: s scm_args=cons(a, nil) scm_args=cons(mk_string(s), scm_args) oper=OP_ERR0 write(*,'(/5a)') ' At: "', scheme_lin(1:currentline), '^', & trim(scheme_lin(currentline+1:eol)) , '"' end subroutine error1 ! subroutine init_scheme() call setup_mem(100) call init_globals() end subroutine init_scheme ! ! Scheme read-eval-print loop ! subroutine repl_scheme(inline, ple) integer, intent(in) :: inline integer, intent(in) :: ple integer :: i, op, plevel integer, save :: mlevel = 1 plevel=0 prompt_string='%% ' if (inline == 1) then mlevel=inline oper = OP_T0LVL currentline=0 scheme_lin=' ' else if (inline == 2) then mlevel=inline oper = OP_T0LVL currentline=0 i=1 do while (lin(i:i) == ' ') i=i+1 end do do while (lin(i:i) /= ' ') i=i+1 end do i=i+1 scheme_lin=lin(i:len_trim(lin)) // ' (quit)' if (ple < -1) plevel=-1 else if (inline == 3) then mlevel=inline plevel=-1 oper = OP_T0LVL currentline=0 scheme_lin=trim(scheme_lin) // ' (quit)' else if (ple > 1) then i=len_trim(scheme_lin) write(*,*) 'Resuming at ', currentline, ' of ', eol, ' characters, in' write(*,*) '"', scheme_lin(1:(currentline-1)), '^', & scheme_lin(currentline:i), '"' end if oper=OP_EVAL end if eol=len_trim(scheme_lin) ! do op=oper if (op == OP_ERR0 .or. op == OP_ERR1) then if (mlevel==2) exit mlevel=1 end if if (op == OP_QUIT) then if (inline==1) write(*, '(a)') 'Leaving scheme!' exit else if (op >= OP_LOAD .and. op <= OP_LET2AST) then call opexe0(op, mlevel) else if (op >= OP_LET0REC .and. op <= OP_CONTINUATION) then call opexe1(op) else if (op >= OP_ADD .and. op <= OP_SETCDR) then call opexe2(op) else if (op >= OP_NOT .and. op <= OP_EQV) then call opexe3(op) else if (op >= OP_FORCE .and. op <= OP_NEWSEGMENT) then call opexe4(op, plevel) else if (op >= OP_RDSEXPR .and. op <= OP_P1LIST) then call opexe5(op, plevel) else if (op >= OP_LIST_LENGTH .and. op <= OP_MACROP) then call opexe6(op) else if (op >= OP_EXP .and. op <= OP_EXPT) then call opexe7(op) else if (op >= OP_MIN .and. op <= OP_RANDOM) then call opexe8(op) else if (op >= OP_MKSTRING .and. op <= OP_STR2SYM) then call opexe9(op) else if (op >= OP_SYSTEM .and. op <= OP_HELP) then call opexe10(op, plevel) else if (op >= OP_PNORM .and. op <= OP_ALNGAM) then call opexe11(op) #if JAPI else if (op >= OP_JSTART .and. op <= OP_JSETFLOWLAYOUT) then call opexe12(op) #endif else write(*, '(a)') 'Bad op code! Exiting!' exit end if end do prompt_string='>> ' end subroutine repl_scheme end module scheme_lang ! ! Stub of main program ! program main use rndseed use interrupt use scheme_lang integer :: plevel integer :: session_typ ix=12345 iy=12345 iz=12345 call init_scheme() plevel=0 session_typ=1 call repl_scheme(session_typ, plevel) call cleanup_mem() end program main