summaryrefslogtreecommitdiff
path: root/ipl/packs/skeem
diff options
context:
space:
mode:
Diffstat (limited to 'ipl/packs/skeem')
-rw-r--r--ipl/packs/skeem/Makefile22
-rw-r--r--ipl/packs/skeem/READ_ME59
-rw-r--r--ipl/packs/skeem/llist.icn174
-rw-r--r--ipl/packs/skeem/skbasic.icn350
-rw-r--r--ipl/packs/skeem/skcontrl.icn150
-rw-r--r--ipl/packs/skeem/skdebug.icn38
-rw-r--r--ipl/packs/skeem/skeem.icn152
-rw-r--r--ipl/packs/skeem/skextra.icn177
-rw-r--r--ipl/packs/skeem/skfun.icn114
-rw-r--r--ipl/packs/skeem/skin.icn233
-rw-r--r--ipl/packs/skeem/skio.icn188
-rw-r--r--ipl/packs/skeem/sklist.icn252
-rw-r--r--ipl/packs/skeem/skmisc.icn128
-rw-r--r--ipl/packs/skeem/sknumber.icn440
-rw-r--r--ipl/packs/skeem/skout.icn105
-rw-r--r--ipl/packs/skeem/skstring.icn360
-rw-r--r--ipl/packs/skeem/skuser.icn45
-rw-r--r--ipl/packs/skeem/skutil.icn206
-rw-r--r--ipl/packs/skeem/test.scm979
-rw-r--r--ipl/packs/skeem/test.std1180
20 files changed, 5352 insertions, 0 deletions
diff --git a/ipl/packs/skeem/Makefile b/ipl/packs/skeem/Makefile
new file mode 100644
index 0000000..fa10f0b
--- /dev/null
+++ b/ipl/packs/skeem/Makefile
@@ -0,0 +1,22 @@
+ICONT=icont
+IFLAGS=-us
+
+SRC = skeem.icn skbasic.icn skcontrl.icn skdebug.icn skextra.icn skfun.icn \
+ skin.icn skio.icn sklist.icn skmisc.icn sknumber.icn skout.icn \
+ skstring.icn skuser.icn skutil.icn llist.icn
+
+
+skeem: $(SRC)
+ $(ICONT) $(IFLAGS) $(SRC)
+
+
+Test: skeem
+ MSTKSIZE=500000 ./skeem test.scm >test.out
+ cmp test.std test.out
+
+
+Iexe: skeem
+ cp skeem ../../iexe/
+
+Clean:
+ rm -f skeem *.u? *.out tmp?
diff --git a/ipl/packs/skeem/READ_ME b/ipl/packs/skeem/READ_ME
new file mode 100644
index 0000000..bd3b31a
--- /dev/null
+++ b/ipl/packs/skeem/READ_ME
@@ -0,0 +1,59 @@
+############################################################################
+#
+# Name: READ_ME
+#
+# Title: Scheme in Icon
+#
+# Author: Bob Alexander
+#
+# Date: February 19, 1995
+#
+# Description: R4RS Scheme, with the exception that continuations
+# are escape procedures only (i.e. do no have unlimited
+# extent)
+#
+# Note: Running the standard Scheme test suite requires
+# enlarging the Icon stack by setting MSTKSIZE.
+#
+############################################################################
+
+To build, translate and link all .icn files in this directory:
+
+ icont *.icn
+
+Files
+~~~~~
+llist.icn Operations on linked lists, Lisp-style
+
+skbasic.icn Miscellaneous basic syntaxes and procedures:
+ Literal expressions
+ Lambda expressions
+ Conditionals
+ Assignments
+ Derived expression types
+ Binding constructs
+ Sequencing
+ Iteration
+ Delayed evaluation
+ Quasiquotation
+ Definitions
+skcontrl.icn Control procedures
+skdebug.icn Debugging utility procedures (not needed for "production" version)
+skeem.icn Main program, initialization, and read/eval/print procedure
+skextra.icn Some additional stuff not in the standard
+skfun.icn Function/syntax list format & definitions
+skin.icn Input utility procedures
+skio.icn Output procedures
+sklist.icn List and vector procedures
+skmisc.icn Various procedures:
+ Booleans
+ Equivalence predicates
+ Symbols
+ System interface
+sknumber.icn Number procedures
+skout.icn Output utility procedures
+skstring.icn String and character procedures
+skuser.icn Initialization list for user-defined functions
+skutil.icn Miscellaneous utility procedures
+
+test.scm Standard Scheme test suite
diff --git a/ipl/packs/skeem/llist.icn b/ipl/packs/skeem/llist.icn
new file mode 100644
index 0000000..8574db7
--- /dev/null
+++ b/ipl/packs/skeem/llist.icn
@@ -0,0 +1,174 @@
+############################################################################
+#
+# Name: llist.icn
+#
+# Title: Linked-list utilities, Lisp-style
+#
+# Author: Bob Alexander
+#
+# Date: February 19, 1995
+#
+############################################################################
+
+#
+# Procedure kit supporting operations on linked lists, Lisp-style.
+#
+
+global LLNull
+
+record LLPair(first,rest)
+
+#
+# Basic list operations.
+#
+
+procedure LLFirst(x)
+ return (\x).first
+end
+
+procedure LLRest(x)
+ return (\x).rest
+end
+
+
+#
+# Predicates -- the predicates fail if false, and return their arguments if
+# true. Note that the returned value for the true condition might be null.
+#
+
+procedure LLIsNull(x)
+ return /x
+end
+
+procedure LLIsPair(x)
+ return (type(x) == "LLPair",x)
+end
+
+procedure LLIsNotPair(x)
+ return (type(x) ~== "LLPair",x)
+end
+
+procedure LLIsList(x)
+ return (LLIsNull | LLIsPair)(x)
+end
+
+procedure LLIsNotList(x)
+ return (not (LLIsNull | LLIsPair)(x),x)
+end
+
+
+#
+# More list operations.
+#
+
+procedure LList(x[])
+ local ll
+ every ll := LLPair(!x,ll)
+ return LLInvert(ll)
+end
+
+procedure LLToList(ll)
+ local result
+ result := []
+ every put(result,LLElements(ll))
+ return result
+end
+
+procedure LLAppend(ll[])
+ local result
+ every result := LLPair(LLElements(ll[1 to *ll - 1]),result)
+ return LLInvert(result,ll[-1] | &null)
+end
+
+procedure LLSplice(ll[])
+ local result,x,prev
+ every x := !ll do {
+ result := \x
+ (\prev).rest := x
+ prev := LLLastPair(x)
+ }
+ return result
+end
+
+procedure LLLastPair(ll)
+ local result
+ every result := LLPairs(ll)
+ return \result
+end
+
+procedure LLPut(ll,x)
+ return ((\LLLastPair(ll)).rest := LLPair(x),ll) | LLPair(x)
+end
+
+procedure LLInvert(ll,dot)
+ local nxt
+ while \ll do {
+ nxt := ll.rest
+ ll.rest := dot
+ dot := ll
+ ll := nxt
+ }
+ return dot
+end
+
+procedure LLReverse(ll)
+ local new_list
+ every new_list := LLPair(LLElements(ll),new_list)
+ return new_list
+end
+
+procedure LLElements(ll)
+ while LLIsPair(ll) do {
+ suspend ll.first
+ ll := ll.rest
+ }
+end
+
+procedure LLPairs(ll)
+ while LLIsPair(ll) do {
+ suspend ll
+ ll := ll.rest
+ }
+end
+
+procedure LLSecond(ll)
+ return (\(\ll).rest).first
+end
+
+procedure LLThird(ll)
+ return LLElement(ll,3)
+end
+
+procedure LLElement(ll,i)
+ return LLTail(ll,i).first
+end
+
+procedure LLTail(ll,i)
+ return 1(LLPairs(ll),(i -:= 1) = 0)
+end
+
+procedure LLCopy(ll)
+ return LLInvert(LLReverse(ll))
+end
+
+procedure LLLength(ll)
+ local result
+ result := 0
+ every LLPairs(ll) do result +:= 1
+ return result
+end
+
+procedure LLImage(x)
+ local result,pair
+ return {
+ if /x then "()"
+ else if LLIsPair(x) then {
+ result := "("
+ every pair := LLPairs(x) do
+ result ||:= LLImage(pair.first) || " "
+ if /pair.rest then result[1:-1] || ")"
+ else result || ". " || LLImage(pair.rest) || ")"
+ }
+ else image(x)
+ }
+end
diff --git a/ipl/packs/skeem/skbasic.icn b/ipl/packs/skeem/skbasic.icn
new file mode 100644
index 0000000..efa0bc1
--- /dev/null
+++ b/ipl/packs/skeem/skbasic.icn
@@ -0,0 +1,350 @@
+############################################################################
+#
+# Name: skbasic.icn
+#
+# Title: Scheme in Icon
+#
+# Author: Bob Alexander
+#
+# Date: March 23, 1995
+#
+# Description: see skeem.icn
+#
+############################################################################
+
+#
+# skeem -- Scheme in Icon
+#
+# Miscellaneous basic syntaxes and procedures:
+#
+# Literal expressions
+# Lambda expressions
+# Conditionals
+# Assignments
+# Derived expression types
+# Binding constructs
+# Sequencing
+# Iteration
+# Delayed evaluation
+# Quasiquotation
+# Definitions
+#
+
+#
+# Initialize
+#
+# List entries are described in skfun.icn.
+#
+procedure InitBasic()
+ DefSyntax([
+ AND,&null,
+ BEGIN,"oneOrMore",
+ CASE,"twoOrMore",
+ COND,1,&null,
+ DEFINE,"twoOrMore",
+ DELAY,
+ DO,"twoOrMore",
+ IF,2,3,
+ LAMBDA,"oneOrMore",
+ LET,"twoOrMore",
+ LETREC,"twoOrMore",
+ LET_STAR_,"twoOrMore","LET*",
+ OR,&null,
+ QUASIQUOTE,
+ QUOTE,
+ SET_BANG,2])
+ return
+end
+
+
+#
+# Literal expressions
+#
+
+procedure QUOTE(value)
+ return value
+end
+
+
+#
+# Lambda expressions
+#
+
+procedure LAMBDA(argList,body[])
+ local argListMin,argListMax
+ if LLIsList(argList) then {
+ argListMin := LLLength(argList)
+ argListMax := if LLIsNull(LLRest(LLLastPair(argList))) then argListMin
+ }
+ else argListMin := 0
+ return Lambda(LList!push(body,argList),,argListMin,argListMax,CurrentEnv)
+end
+
+
+#
+# Conditionals
+#
+
+procedure IF(test,clause[])
+ test := Eval(test) | fail
+ return Eval(
+ if F ~=== test then clause[1]
+ else (clause[2] | (return F))\1)
+end
+
+
+#
+# Assignments
+#
+
+procedure SET_BANG(var,value)
+ return SetVar(var,Eval(value))
+end
+
+
+#
+# Derived expression types
+#
+
+procedure COND(body[])
+ local clause,test,second
+ every clause := !body do {
+ second := LLSecond(clause) | return Error(COND,"ill-formed clause")
+ test := LLFirst(clause)
+ if test === "ELSE" | (test := F ~=== (Eval(test) | fail)\1) then {
+ return {
+ if second === "=>" then
+ Eval(LList(LLThird(clause),LList("QUOTE",test)))
+ else
+ EvalSeq(LLRest(clause))
+ }
+ }
+ }
+ return F
+end
+
+procedure CASE(key,body[])
+ local clause,dataList,exprs
+ key := Eval(key) | fail
+ every clause := !body do {
+ \(exprs := LLRest(clause)) | return Error(CASE,"ill-formed clause")
+ dataList := LLFirst(clause)
+ if dataList === "ELSE" | Eqv(key,LLElements(dataList)) then
+ return EvalSeq(exprs)
+ }
+ return F
+end
+
+procedure AND(arg[])
+ local result,element
+ result := T
+ every element := !arg do {
+ result := Eval(element) | fail
+ if result === F then break
+ }
+ return result
+end
+
+procedure OR(arg[])
+ local result,element
+ result := F
+ every element := !arg do {
+ result := Eval(element) | fail
+ if result ~=== F then break
+ }
+ return result
+end
+
+
+#
+# Binding constructs
+#
+
+procedure LET(arg[])
+ local result
+ result := EvalSeq(Let1(arg)) | fail
+ DiscardFrame()
+ return result
+end
+
+procedure Let1(arg)
+ local assignList,init,var,argList,loop,body
+ assignList := []
+ if SymbolP(arg[1]) then {
+ var := get(arg)
+ argList := LLNull
+ every argList := LLPair(LLFirst(LLElements(arg[1])),argList)
+ }
+ every init := LLElements(get(arg)) do
+ put(assignList,LLFirst(init),Eval(LLSecond(init))) | fail
+ PushFrame()
+ body := LList!arg
+ if \var then {
+ loop := LAMBDA!push(arg,LLInvert(argList)) | fail
+ loop.name := var
+ DefVar(var,loop)
+ }
+ while DefVar(get(assignList),get(assignList))
+ return body
+end
+
+procedure LET_STAR_(inits,body[])
+ local init,result
+ PushFrame()
+ every init := LLElements(inits) do
+ DefVar(LLFirst(init),Eval(LLSecond(init))) | {DiscardFrame(); fail}
+ result := EvalSeq(LList!body) | {DiscardFrame(); fail}
+ DiscardFrame()
+ return result
+end
+
+procedure LETREC(inits,body[])
+ local init,result
+ PushFrame()
+ every init := LLElements(inits) do
+ DefVar(LLFirst(init),F)
+ every init := LLElements(inits) do
+ SetVar(LLFirst(init),Eval(LLSecond(init))) | {DiscardFrame(); fail}
+ result := EvalSeq(LList!body) | {DiscardFrame(); fail}
+ DiscardFrame()
+ return result
+end
+
+
+
+#
+# Sequencing
+#
+
+procedure BEGIN(sequence[])
+ return EvalSeq(LList!sequence)
+end
+
+
+#
+# Iteration
+#
+
+procedure DO(inits,test,body[])
+ local testExpr,init,update,result,initList,initEnv,commandEnv
+ testExpr := LLFirst(test) | return Error(DO,"missing test")
+ initList := []
+ every init := LLElements(inits) do
+ put(initList,LLFirst(init),Eval(LLSecond(init))) | fail
+ PushFrame()
+ while DefVar(get(initList),get(initList))
+ body := LList!body
+ while F === (Eval(testExpr) | {DiscardFrame(); fail})\1 do {
+ if \body then EvalSeq(body) | {DiscardFrame(); fail}
+ every init := LLElements(inits) do
+ if update := LLThird(init) then
+ put(initList,LLFirst(init),Eval(update)) | {DiscardFrame(); fail}
+ while SetVar(get(initList),get(initList))
+ }
+ result := EvalSeq(LLRest(test)) | {DiscardFrame(); fail}
+ DiscardFrame()
+ return result
+end
+
+
+#
+# Delayed evaluation
+#
+
+procedure DELAY(expr)
+ return Promise(Lambda(LList(LLNull,expr),,0,0,CurrentEnv))
+end
+
+
+#
+# Quasiquotation
+#
+
+procedure QUASIQUOTE(L)
+ return QuasiQuote(L,0)
+end
+
+invocable "!":1,"|||":2
+
+procedure QuasiQuote(x,nest)
+ static vecElementGen,vecElementConcat
+ initial {
+ vecElementGen := proc("!",1)
+ vecElementConcat := proc("|||",2)
+ }
+ return {
+ if LLIsList(x) then
+ QQExpand(x,nest,LLNull,LLPairs,LLPut,LLAppend,1,LLFirst,LLRest)
+ else if VectorP(x) then
+ QQExpand(x,nest,[],vecElementGen,put,vecElementConcat,LLToList,1,Fail)
+ else
+ x
+ }
+end
+
+procedure Fail()
+end
+
+procedure QQExpand(lst,nest,result,elementGen,elementPut,elementConcat,
+ createFromLList,getElement,getDot)
+ local elt,thunk,dot
+ every thunk := elementGen(lst) do {
+ elt := getElement(thunk)
+ result := {
+ if LLIsPair(elt) then case LLFirst(elt) of {
+ "UNQUOTE":
+ elementPut(result,
+ if nest = 0 then
+ Eval(LLSecond(elt)) | fail
+ else
+ LList("UNQUOTE",QuasiQuote(LLSecond(elt),nest - 1)))
+ "UNQUOTE-SPLICING":
+ if nest = 0 then
+ elementConcat(result,
+ createFromLList(Eval(LLSecond(elt)))) | fail
+ else
+ elementPut(result,
+ LLPair("UNQUOTE-SPLICING",
+ QuasiQuote(LLSecond(elt),nest - 1)))
+ "QUASIQUOTE":
+ elementPut(result,LList("QUASIQUOTE",
+ QuasiQuote(LLSecond(elt),nest + 1)))
+ default:
+ elementPut(result,QuasiQuote(elt,nest))
+ }
+ else if VectorP(elt) & elt[1] === "QUASIQUOTE" then
+ elementPut(result,["QUASIQUOTE",QuasiQuote(elt[2],nest + 1)])
+ else if elt === "UNQUOTE" then {
+ (LLRest(LLLastPair(result)) | result)\1 :=
+ if nest = 0 then
+ Eval(LLFirst(LLRest(thunk))) | fail
+ else
+ LList("UNQUOTE",QuasiQuote(LLFirst(LLRest(thunk)),nest - 1))
+ return result
+ }
+ else elementPut(result,QuasiQuote(elt,nest))
+ }
+ }
+ if dot := \getDot(thunk) then
+ LLRest(result) := QuasiQuote(dot,nest)
+ return result
+end
+
+
+#
+# Definitions
+#
+
+procedure DEFINE(sym,body[])
+ local value
+ if LLIsPair(sym) then {
+ # (define (f x) ...) -> (define f (lambda (x) ...))
+ value := LAMBDA!push(body,LLRest(sym)) | fail
+ sym := LLFirst(sym)
+ }
+ else value := Eval(body[1]) | fail
+ if type(value) == ("Lambda" | "Macro") then
+ /value.name := sym
+ DefVar(sym,value)
+ return sym
+end
diff --git a/ipl/packs/skeem/skcontrl.icn b/ipl/packs/skeem/skcontrl.icn
new file mode 100644
index 0000000..87ee2ba
--- /dev/null
+++ b/ipl/packs/skeem/skcontrl.icn
@@ -0,0 +1,150 @@
+############################################################################
+#
+# Name: skcontrl.icn
+#
+# Title: Scheme in Icon
+#
+# Author: Bob Alexander
+#
+# Date: March 23, 1995
+#
+# Description: see skeem.icn
+#
+############################################################################
+
+#
+# skeem -- Scheme in Icon
+#
+# Control procedures
+#
+
+#
+# Initialize
+#
+# List entries are described in skfun.icn.
+#
+procedure InitControl()
+ DefFunction([
+ APPLY,"oneOrMore",
+ CALL_WITH_CURRENT_CONTINUATION,
+ CALL_WITH_CURRENT_CONTINUATION,"CALL/CC",
+ FOR_EACH,"oneOrMore",
+ FORCE,
+ MAP,"twoOrMore",
+ PROCEDURE_P])
+ return
+end
+
+
+#
+# Control features
+#
+
+procedure PROCEDURE_P(x)
+ return (type(x) ==
+ ("Lambda" | "Function" | "Syntax" | "Macro"),T) | F
+end
+
+procedure APPLY(fcn,arg[])
+ local last,argList
+ last := pull(arg)
+ argList := LList!arg
+ LLRest(\argList) | argList := last
+ return Apply(fcn,argList)
+end
+
+procedure MAP(fcn,lsts[])
+ local arg,result
+ result := LLNull
+ repeat {
+ arg := MapArgs(lsts) | break
+ result := LLPair(Apply(fcn,arg),result) | fail
+ }
+ return LLInvert(result)
+end
+
+procedure MapArgs(lsts)
+ local arg,i,x
+ arg := LLNull
+ every i := 1 to *lsts do {
+ x := lsts[i]
+ if /x then fail
+ arg := LLPair(LLFirst(x),arg)
+ lsts[i] := LLRest(x)
+ }
+ return LLInvert(arg)
+end
+
+procedure FOR_EACH(fcn,lsts[])
+ local arg,result
+ result := F
+ repeat {
+ arg := MapArgs(lsts) | break
+ result := Apply(fcn,arg) | fail
+ }
+ return result
+end
+
+procedure FORCE(promise)
+ return Force(promise)
+end
+
+procedure Force(promise)
+ local x
+ return {
+ if \promise.ready then
+ promise.result
+ else {
+ x := Apply(promise.proc,LLNull) | fail
+ if \promise.ready then
+ promise.result
+ else {
+ promise.ready := "true"
+ .(promise.result := x)
+ }
+ }
+ }
+end
+
+procedure CALL_WITH_CURRENT_CONTINUATION(func)
+ local continuationProc,checkObj
+ static invokeContinuation,continuationExpr
+ initial {
+ invokeContinuation :=
+ Function(InvokeContinuation,"InvokeContinuation",3,3)
+ continuationExpr :=
+ [LList("VALUE"),
+ LList("INVOKE-CONTINUATION","CONT-LEVEL","VALUE","CHECK-OBJ")]
+ }
+ PushFrame()
+ DefVar("CONT-LEVEL",&level)
+ DefVar("INVOKE-CONTINUATION",invokeContinuation)
+ DefVar("CHECK-OBJ",checkObj := CurrentEnv)
+ #
+ # (define continuationProc
+ # (lambda (value) (invoke-continuaton cont-level value check-obj)))
+ #
+ continuationProc := LAMBDA!continuationExpr
+ #
+ DiscardFrame()
+ return Apply(func,LLPair(continuationProc)) |
+ EscapeCheck(&level,checkObj)
+end
+
+procedure InvokeContinuation(data[])
+ EscapeData := data
+ fail
+end
+
+procedure EscapeCheck(level,checkObj)
+ local escapeData
+ if \EscapeData & (/level | EscapeData[1] = level) then {
+ escapeData := EscapeData
+ EscapeData := &null
+ if /level | checkObj ~=== escapeData[3] then
+ return Error(CALL_WITH_CURRENT_CONTINUATION,
+ "escape procedure no longer valid (expires when its call/cc returns)")
+ FailProc := &null
+ return escapeData[2]
+ }
+end
diff --git a/ipl/packs/skeem/skdebug.icn b/ipl/packs/skeem/skdebug.icn
new file mode 100644
index 0000000..5288ad6
--- /dev/null
+++ b/ipl/packs/skeem/skdebug.icn
@@ -0,0 +1,38 @@
+############################################################################
+#
+# Name: skdebug.icn
+#
+# Title: Scheme in Icon
+#
+# Author: Bob Alexander
+#
+# Date: February 19, 1995
+#
+# Description: see skeem.icn
+#
+############################################################################
+
+#
+# skeem -- Scheme in Icon
+#
+# Debugging utility procedures (not needed for "production" version)
+#
+
+procedure ShowEnv(tag,env,showInitial)
+ local frame,pair
+ /env := CurrentEnv
+ write("+++ Environment ",tag)
+ every frame := LLPairs(env) do {
+ if /showInitial & /LLRest(frame) then break
+ write(" +++ Frame:")
+ every pair := !sort(LLFirst(frame)) do {
+ write(" ",Print(pair[1]),"\t",Print(pair[2]))
+ }
+ }
+ return
+end
+
+procedure Show(x[])
+ every write("+++ ",Print(!x))
+ return
+end
diff --git a/ipl/packs/skeem/skeem.icn b/ipl/packs/skeem/skeem.icn
new file mode 100644
index 0000000..9e7fcc6
--- /dev/null
+++ b/ipl/packs/skeem/skeem.icn
@@ -0,0 +1,152 @@
+############################################################################
+#
+# Name: skeem.icn
+#
+# Title: Scheme in Icon
+#
+# Author: Bob Alexander
+#
+# Date: February 19, 1995
+#
+# Description: R4RS Scheme, with the exception that continuations
+# are escape procedures only (i.e. do no have unlimited
+# extent)
+#
+############################################################################
+
+#
+# skeem -- Scheme in Icon
+#
+# Main program, initialization, and read/eval/print procedure
+#
+
+link llist,escapesq,options
+link skfun,skbasic,skcontrl,skio,sklist,skmisc,sknumber,skstring,skextra
+link skutil,skin,skout
+#link skdebug
+#link ximage
+
+global GlobalEnv,UserEnv,CurrentEnv, # environments
+ T,F,NIL,Unbound,Failure, # universal constants
+ InputPortStack,
+ OutputPortStack,
+ EscapeData,FailProc,Resume,BreakLevel,FuncName,
+ EOFObject,
+ Space
+
+global TraceSet, # set of currently traced functions
+ FTrace # flag for tracing all functions
+
+global TraceReader,EchoReader,NoError
+
+record String(value) # used for string datatyepe
+record Char(value) # used for character datatyepe
+record Port(file,option) # used for port datatyepe
+record Symbol(string,value)
+record Promise(proc,ready,result)
+record UniqueObject(name)
+record Value(value)
+
+record Function(proc,name,minArgs,maxArgs,traced)
+record Lambda(proc,name,minArgs,maxArgs,env,traced)
+record Macro(proc,name,minArgs,maxArgs,env,traced)
+record Syntax(proc,name,minArgs,maxArgs,traced)
+
+#
+# main() -- Analyzes the arguments and invokes the read/eval/print loop.
+#
+procedure main(arg)
+ local fn,f
+ Initialize(arg)
+ if *arg = 0 then arg := ["-"]
+ if \TraceReader then &trace := -1
+ every fn := !arg do {
+ f := if fn == "-" then &input else open(fn) | stop("Can't open ",fn)
+ ReadEvalPrint(f,,"top")
+ }
+end
+
+#
+# Initialize() - Set up global values
+#
+procedure Initialize(arg)
+ Options(arg)
+ Space := ' \t\n\r\l\v\f'
+ T := UniqueObject("#t")
+ F := UniqueObject("#f")
+ Unbound := UniqueObject("unbound")
+ Failure := UniqueObject("failure")
+ EOFObject := UniqueObject("EOF object")
+ NIL := &null
+ BreakLevel := 0
+ InputPortStack := [Port(&input,"r")]
+ OutputPortStack := [Port(&output,"w")]
+ TraceSet := set()
+ GlobalEnv := PushFrame()
+ InitFunctions()
+ UserEnv := PushFrame()
+#########
+## every x := !sort(LLFirst(GlobalEnv)) do {
+## y := x[2]
+## sname := if ProcName(y.proc) == y.name then "" else " " || y.name
+## write(right(y.minArgs,2),right(\y.maxArgs,2) | " -"," ",image(y.proc)[11:0],sname)
+## }
+#########
+ return
+end
+
+procedure Options(arg)
+ local opt
+ opt := options(arg,"tre")
+ TraceReader := opt["t"]
+ EchoReader := opt["r"]
+ NoError := opt["e"]
+ return opt
+end
+
+#
+# ReadEvalPrint() -- The R/E/P loop.
+#
+procedure ReadEvalPrint(f,quiet,top)
+ local sexpr,value,saveEnv
+ every sexpr := ReadAllExprs(f) do {
+ if \EchoReader then write("Read: ",Print(sexpr))
+ saveEnv := CurrentEnv
+ EscapeData := Resume := &null
+ if /NoError then &error := 1
+ if value := Eval(sexpr) then (if /quiet then write(Print(value)))
+ else {
+ #
+ # The expression failed -- why?
+ #
+ if \Resume then {
+ if /top then {
+ if Resume === "top" then fail # (top)
+ return 1(.Resume.value,Resume := &null) # (resume x)
+ }
+ if Resume ~=== "top" then {
+ Error("READ-EVAL-PRINT","Can't resume from top level")
+ Resume := &null
+ }
+ }
+ else {
+ EscapeCheck() # escape that doesn't exist (any more)
+ ErrorCheck() # run-time error
+ }
+ CurrentEnv := saveEnv
+ }
+ }
+ return value
+end
+
+procedure ErrorCheck()
+ if &errornumber then {
+ Error(FailProc,"Icon run-time error: ",&errortext,
+ ("\n offending value:_
+ \n skeem representation: " || Print(&errorvalue) || "_
+ \n Icon representation: " || image(&errorvalue) | "")\1)
+ FailProc := &null
+ errorclear()
+ }
+ else return
+end
diff --git a/ipl/packs/skeem/skextra.icn b/ipl/packs/skeem/skextra.icn
new file mode 100644
index 0000000..fc6b8cf
--- /dev/null
+++ b/ipl/packs/skeem/skextra.icn
@@ -0,0 +1,177 @@
+############################################################################
+#
+# Name: skextra.icn
+#
+# Title: Scheme in Icon
+#
+# Author: Bob Alexander
+#
+# Date: March 23, 1995
+#
+# Description: see skeem.icn
+#
+############################################################################
+
+#
+# skeem -- Scheme in Icon
+#
+# Some additional stuff not in the standard
+#
+
+#
+# Initialize
+#
+# List entries are described in skfun.icn.
+#
+procedure InitExtra()
+ #
+ # Functions
+ #
+ DefFunction([
+ ADD1,
+ ATOM_P,
+ BREAK,0,
+ BREAK_LEVEL,0,
+ EVAL,1,2,
+ QUIT,0,1,
+ READ_LINE,0,1,
+ RESUME,0,1,
+ SUB1,
+ TOP,0,
+ TRACE,&null,
+ UNTRACE,&null])
+ #
+ # Syntaxes
+ #
+ DefSyntax([
+ DEFINE_MACRO,"twoOrMore",
+ ITRACE,
+ ITRACEOFF,0,
+ ITRACEON,0,
+ REPEAT,"oneOrMore",
+ TRACE_ALL,0,
+ UNLESS,"oneOrMore",
+ WHEN,"oneOrMore"])
+ return
+end
+
+procedure EVAL(ex,env)
+ return Eval(ex,env)
+end
+
+procedure QUIT(exitCode)
+ exit(exitCode)
+end
+
+procedure WHEN(test,body[])
+ return if F ~=== (Eval(test) | fail)\1 then
+ EvalSeq(LList!body) | fail
+end
+
+procedure UNLESS(test,body[])
+ return if F === (Eval(test) | fail)\1 then
+ EvalSeq(LList!body) | fail
+end
+
+procedure REPEAT(count,body[])
+ local result
+ body := LList!body
+ every 1 to count do
+ result := EvalSeq(body) | fail
+ return result
+end
+
+procedure ATOM_P(arg)
+ return (LLIsNotPair(arg),T) | F
+end
+
+procedure BREAK()
+ local result
+ BreakLevel +:= 1
+ result := ReadEvalPrint((InputPortStack[1].file | &input)\1) | Failure
+ BreakLevel -:= 1
+ return Failure ~=== result
+end
+
+procedure BREAK_LEVEL()
+ return BreakLevel
+end
+
+procedure RESUME(value)
+ Resume := Value(\value | F)
+ fail
+end
+
+procedure TOP()
+ Resume := "top"
+ fail
+end
+
+procedure TRACE(funcs[])
+ local fn,result,element
+ if *funcs = 0 then {
+ result := LLNull
+ every result := LLPair((!sort(TraceSet)).name,result)
+ return LLInvert(result)
+ }
+ else every element := !funcs do {
+ fn := Eval(element) | fail
+ fn.traced := "true"
+ insert(TraceSet,fn)
+ return NIL
+ }
+end
+
+procedure UNTRACE(funcs[])
+ local fn,element
+ if *funcs = 0 then {
+ FTrace := &null
+ every (!TraceSet).traced := &null
+ }
+ else every element := !funcs do {
+ fn := Eval(element) | fail
+ fn.traced := &null
+ delete(TraceSet,fn)
+ }
+ return NIL
+end
+
+procedure ITRACEON()
+ return (&trace := -1,T)
+end
+
+procedure ITRACEOFF()
+ return (&trace := 0,F)
+end
+
+procedure ITRACE(expr)
+ local value
+ &trace := -1
+ value := Eval(expr) | Failure
+ &trace := 0
+ return Failure ~=== value
+end
+
+procedure TRACE_ALL()
+ return FTrace := T
+end
+
+procedure DEFINE_MACRO(arg)
+ local sym,value
+ return Error(DEFINE_MACRO,"Not implemented for now")
+## return DEFINE(arg,,Macro)
+end
+
+procedure ADD1(n)
+ return n + 1
+end
+
+procedure SUB1(n)
+ return n - 1
+end
+
+procedure READ_LINE(port)
+ local f
+ f := (\port | InputPortStack[1]).file
+ return String(read(f)) | EOFObject
+end
diff --git a/ipl/packs/skeem/skfun.icn b/ipl/packs/skeem/skfun.icn
new file mode 100644
index 0000000..f5bec79
--- /dev/null
+++ b/ipl/packs/skeem/skfun.icn
@@ -0,0 +1,114 @@
+############################################################################
+#
+# Name: skfun.icn
+#
+# Title: Scheme in Icon
+#
+# Author: Bob Alexander
+#
+# Date: March 23, 1995
+#
+# Description: see skeem.icn
+#
+############################################################################
+
+#
+# skeem -- Scheme in Icon
+#
+
+#
+# Function/syntax list format
+#
+# Each function and syntax defined appears in a definition list which is
+# processed at skeem-initialization time. The following are the rules
+# for function/syntax list entries:
+#
+# - Each entry begins with a procedure name and ends just preceding
+# the next procedure name or the end of the list.
+# - Rules regarding number of arguments:
+# - If an entry contains the object "oneOrMore", then it requires
+# at least one argument.
+# - If an entry contains the object "twoOrMore", then it requires
+# at least two arguments.
+# - If an entry contains one number N, it requires exactly N
+# arguements.
+# - If an entry contains a number N followed by &null, the function
+# requires at least N arguments.
+# - If an entry contains a number N followed by a number M, the
+# function requires at least N arguments but can take no more than
+# M arguments.
+# - If an entry contains no numbers but contains &null, the function
+# can take any number of arguments.
+# - If an entry contains no numbers and no &null, the procedure
+# requires exactly one argument.
+# - If an entry contains a string, then that string is used as the
+# function's skeem-name rather that the name calculated from its
+# Icon procedure name.
+#
+
+procedure InitFunctions()
+ every (
+ InitBasic | # basic syntaxes skbasic.icn
+ InitControl | # control functions skcontrl.icn
+ InitIO | # I/O functions skio.icn
+ InitList | # list & vector functions sklist.icn
+ InitMisc | # misc functions skmisc.icn
+ InitNumber | # number functions sknumber.icn
+ InitString | # string and char functions skstring.icn
+ \!InitUser())() # user-defined functions skuser.icn
+end
+
+procedure DefFunction(prcList,funType)
+ local item,funName,prc,minArgs,maxArgs,gotNull,special
+ /funType := Function
+ prc := get(prcList)
+ while \prc do {
+ funName := minArgs := maxArgs := gotNull := special := &null
+ repeat {
+ (item := get(prcList)) | {
+ item := &null
+ break
+ }
+ if type(item) == "procedure" then break
+ if type(item) == "integer" then /minArgs | maxArgs := item
+ else if /item then gotNull := "true"
+ else if type(item) == "string" then
+ (if item == ("oneOrMore" | "twoOrMore") then special
+ else funName) := item
+ }
+ if special === "oneOrMore" then minArgs := 1
+ else if special === "twoOrMore" then minArgs := 2
+ else if /minArgs then
+ if \gotNull then minArgs := 0
+ else minArgs := maxArgs := 1
+ else if /gotNull then
+ /maxArgs := minArgs
+ /funName := ProcName(prc)
+ #write("+++ ",funName,": ",image(prc),", ",image(minArgs),", ",
+ # image(maxArgs))
+ DefVar(funName,funType(prc,funName,minArgs,maxArgs))
+ prc := item
+ }
+ return
+end
+
+procedure DefSyntax(prc)
+ return DefFunction(prc,Syntax)
+end
+
+procedure ProcName(prc)
+ local nm
+ image(prc) ? {
+ tab(find(" ") + 1)
+ nm := ""
+ while nm ||:= tab(find("_")) do {
+ move(1)
+ nm ||:= if ="BANG" & pos(0) then "!"
+ else if ="2_" then "->"
+ else if ="P" & pos(0) then "?"
+ else "-"
+ }
+ nm ||:= tab(0)
+ }
+ return nm
+end
diff --git a/ipl/packs/skeem/skin.icn b/ipl/packs/skeem/skin.icn
new file mode 100644
index 0000000..1fc8ed7
--- /dev/null
+++ b/ipl/packs/skeem/skin.icn
@@ -0,0 +1,233 @@
+############################################################################
+#
+# Name: skin.icn
+#
+# Title: Scheme in Icon
+#
+# Author: Bob Alexander
+#
+# Date: February 19, 1995
+#
+# Description: see skeem.icn
+#
+############################################################################
+
+#
+# skeem -- Scheme in Icon
+#
+# Input utility procedures
+#
+
+global BackToken
+
+#
+# ReadAllExprs() - Generate expressions from file f
+#
+procedure ReadAllExprs(f)
+ "" ? (suspend |ScanExpr(FileRec(f)))
+end
+
+#
+# ReadOneExpr() - Read one expression from f.
+#
+procedure ReadOneExpr(f)
+ local result,fRec
+ "" ? {
+ result := ScanExpr(fRec := FileRec(f))
+ seek(f,fRec.where + &pos - 1)
+ }
+ return result
+end
+
+#
+# StringToExpr() - Generate expressions from string s
+#
+procedure StringToExpr(s)
+ s ? (suspend |ScanExpr())
+end
+
+procedure ScanExpr(f)
+ local token
+ return case token := ScanToken(f) | fail of {
+ "(": ScanList(f)
+ "#(": ScanVector(f)
+ !"'`," | ",@": ScanQuote(f,token)
+ default:
+ if type(token) == "Symbol" then token.string
+ else token
+ }
+end
+
+procedure ScanList(f)
+ local result,token,dot
+ result := LLNull
+ while (token := ScanToken(f)) ~=== ")" do {
+ if token === "." then {
+ dot := ScanExpr(f)
+ }
+ else {
+ BackToken := token
+ result := LLPair(ScanExpr(f),result)
+ }
+ }
+ return LLInvert(result,dot)
+end
+
+procedure ScanVector(f)
+ local result,token
+ result := []
+ while (token := ScanToken(f)) ~=== ")" do {
+ BackToken := token
+ put(result,ScanExpr(f))
+ }
+ return result
+end
+
+procedure ScanQuote(f,token)
+ return LList(
+ case token of {
+ "'": "QUOTE"
+ "`": "QUASIQUOTE"
+ ",": "UNQUOTE"
+ ",@": "UNQUOTE-SPLICING"
+ },
+ ScanExpr(f))
+end
+
+procedure ScanToken(f)
+ return 1(\.BackToken,BackToken := &null) | {
+ #
+ # Skip over leading white space (including comments, possibly
+ # spanning lines).
+ #
+ #showscan("before space")
+ while {
+ tab(many(Space)) |
+ (if pos(0) then &subject := ReadFileRec(\f)) |
+ (if =";" then tab(0)) |
+ (if ="#|" then {
+ until tab(find("|#") + 2) do &subject := ReadFileRec(\f) | fail
+ &null
+ })
+ }
+ #showscan("after space")
+ #
+ # Scan then token.
+ #
+ ScanSymbol() | ScanNumber() | ScanSpecial() | ScanString() |
+ ScanChar() | ScanBoolean() | move(1)
+ }
+end
+
+procedure ScanSymbol()
+ static symFirst,symRest,nonSym
+ initial {
+ symFirst := &letters ++ '!$%&*/:<=>?~_^'
+ symRest := symFirst ++ &digits ++ '.+-'
+ nonSym := ~symRest
+ }
+ return Symbol(
+ (match("|"),escape(quotedstring("|")[2:-1])) |
+ map(1((tab(any(symFirst)) || (tab(many(symRest)) | "") |
+ =("+" | "-" | "...")),
+ (any(nonSym) | pos(0))),&lcase,&ucase))
+end
+
+procedure ScanNumber()
+ local nbr
+ static nbrFirst,nbrRest
+ initial {
+ nbrFirst := &digits ++ 'eE.'
+ nbrRest := nbrFirst ++ &letters ++ '#+-'
+ }
+ (nbr := ((tab(any('+-')) | "") || tab(any(nbrFirst)) |
+ ="#" || tab(any('bodxeiBODXEI'))) || (tab(many(nbrRest)) | "") &
+ nbr ~== ".") | fail
+ return StringToNumber(nbr) |
+ Error("READER","bad number: ",image(nbr))
+end
+
+procedure StringToNumber(nbr,radix)
+ local exact,sign,number,c
+ radix := if \radix ~= 10 then radix || "r" else ""
+ sign := ""
+ exact := 1
+ map(nbr) ? return {
+ while ="#" do case move(1) of {
+ "b": radix := "2r"
+ "o": radix := "8r"
+ "d": radix := ""
+ "x": radix := "16r"
+ "e": exact := Round
+ "i": exact := real
+ default: &null # this case prevents the expression from failing
+ }
+ sign := tab(any('+-'))
+ number := ""
+ while number ||:= tab(upto('#sfdl')) do {
+ c := move(1)
+ number ||:=
+ if c == "#" then {
+ if exact === 1 then exact := real
+ "0"
+ }
+ else "e"
+ }
+ number ||:= tab(0)
+ #write(&errout,"+++++ exact = ",image(exact),
+ # "; radix = ",image(radix),"; sign = ",image(sign),
+ # "; number = ",image(number))
+ exact(numeric(sign || radix || number))
+ }
+end
+
+procedure ScanSpecial()
+ return =("#(" | ",@" | !"()'`,") |
+ (="#<",Error("READER","unreadable object #<",tab(find(">") + 1 | 0)),F)
+end
+
+procedure ScanBoolean()
+ return (="#",(=!"fF",F) | (=!"tT",T))
+end
+
+procedure ScanString()
+ return String((match("\""),escape(quotedstring()[2:-1])))
+end
+
+procedure ScanChar()
+ local chName
+ return Char((="#\\",
+ (case map(1(chName := tab(many(&letters)),*chName > 1)) of {
+ "space": " "
+ "tab": "\t"
+ "newline": "\n"
+ "backspace": "\b"
+ "delete": "\d"
+ "escape": "\e"
+ "formfeed": "\f"
+ "return": "\r"
+ "verticaltab": "\v"
+ default: Error("READER","unknown character name")
+ }) | move(1)))
+end
+
+record FileRec(file,where)
+
+procedure ReadFileRec(f)
+ local line
+ static doPrompt
+ initial doPrompt := if find("MPW",&host) then &null else "true"
+ f.where := where(f.file)
+ if f.file === &input then {
+ if \doPrompt then
+ writes(if BreakLevel = 0 then "> " else "[" || BreakLevel || "] ")
+ line := read() | fail
+## line ? {
+## if =">" | (="[" || tab(find("]") + 1)) then
+## \f.where +:= &pos - 1
+## line := tab(0)
+## }
+ return line
+ }
+ else return read(f.file)
+end
diff --git a/ipl/packs/skeem/skio.icn b/ipl/packs/skeem/skio.icn
new file mode 100644
index 0000000..068a4b6
--- /dev/null
+++ b/ipl/packs/skeem/skio.icn
@@ -0,0 +1,188 @@
+############################################################################
+#
+# Name: skio.icn
+#
+# Title: Scheme in Icon
+#
+# Author: Bob Alexander
+#
+# Date: March 23, 1995
+#
+# Description: see skeem.icn
+#
+############################################################################
+
+#
+# skeem -- Scheme in Icon
+#
+# Output procedures
+#
+
+#
+# Initialize
+#
+# List entries are described in skfun.icn.
+#
+procedure InitIO()
+ DefFunction([
+ CALL_WITH_INPUT_FILE,2,
+ CALL_WITH_OUTPUT_FILE,2,
+ CLOSE_INPUT_PORT,
+ CLOSE_OUTPUT_PORT,
+ CURRENT_INPUT_PORT,0,
+ CURRENT_OUTPUT_PORT,0,
+ DISPLAY,1,2,
+ EOF_OBJECT_P,
+ INPUT_PORT_P,
+ NEWLINE,0,1,
+ OPEN_INPUT_FILE,
+ OPEN_OUTPUT_FILE,
+ OUTPUT_PORT_P,
+ PEEK_CHAR,0,1,
+ READ,0,1,
+ READ_CHAR,0,1,
+ WITH_INPUT_FROM_FILE,2,
+ WITH_OUTPUT_FROM_FILE,2,
+ WRITE,1,2,
+ WRITE_CHAR,1,2])
+ return
+end
+
+
+#
+# Input and Output
+#
+# Ports
+#
+
+procedure CALL_WITH_INPUT_FILE(file,func)
+ return CallWithFile(file,func,"r",CALL_WITH_INPUT_FILE)
+end
+
+procedure CALL_WITH_OUTPUT_FILE(file,func)
+ return CallWithFile(file,func,"w",CALL_WITH_OUTPUT_FILE)
+end
+
+procedure CallWithFile(file,func,option,funName)
+ local f,result
+ f := OpenFile(file,option,funName) | fail
+ result := Apply(func,LLPair(Port(f,option))) | fail
+ close(f)
+ return result
+end
+
+procedure INPUT_PORT_P(x)
+ return (type(x) == "Port",find("w",x.option),F) | T
+end
+
+procedure OUTPUT_PORT_P(x)
+ return (type(x) == "Port",find("w",x.option),T) | F
+end
+
+procedure CURRENT_INPUT_PORT()
+ return InputPortStack[1]
+end
+
+procedure CURRENT_OUTPUT_PORT()
+ return OutputPortStack[1]
+end
+
+procedure WITH_INPUT_FROM_FILE(file,func)
+ return WithFile(file,func,"r",WITH_INPUT_FROM_FILE,InputPortStack)
+end
+
+procedure WITH_OUTPUT_FROM_FILE(file,func)
+ return WithFile(file,func,"w",WITH_OUTPUT_FROM_FILE,OutputPortStack)
+end
+
+procedure WithFile(file,func,option,funName,portStack)
+ local f,result
+ f := OpenFile(file,option,funName) | fail
+ push(portStack,Port(f,option))
+ result := Apply(func,LLNull) | fail
+ close(f)
+ pop(portStack)
+ return result
+end
+
+procedure OpenFile(file,option,funName)
+ local fn
+ fn := file.value | fail
+ return open(fn,option) |
+ Error(funName,"Can't open file ",file)
+end
+
+procedure OPEN_INPUT_FILE(file)
+ return Port(OpenFile(file,"r",OPEN_INPUT_FILE),"r")
+end
+
+procedure OPEN_OUTPUT_FILE(file)
+ return Port(OpenFile(file,"w",OPEN_OUTPUT_FILE),"w")
+end
+
+procedure CLOSE_INPUT_PORT(port)
+ return ClosePort(port)
+end
+
+procedure CLOSE_OUTPUT_PORT(port)
+ return ClosePort(port)
+end
+
+procedure ClosePort(port)
+ close(port.file)
+ return port
+end
+
+#
+# Input
+#
+
+procedure READ(port)
+ local f
+ f := (\port | InputPortStack[1]).file
+ return ReadOneExpr(f) | EOFObject
+end
+
+procedure READ_CHAR(port)
+ local f
+ f := (\port | InputPortStack[1]).file
+ return Char(reads(f)) | EOFObject
+end
+
+procedure PEEK_CHAR(port)
+ local f
+ f := (\port | InputPortStack[1]).file
+ return Char(1(reads(f),seek(f,where(f) - 1))) | EOFObject
+end
+
+procedure EOF_OBJECT_P(x)
+ return (x === EOFObject,T) | F
+end
+
+#
+# Output.
+#
+
+procedure WRITE(value,port)
+ /port := OutputPortStack[1]
+ writes(port.file,Print(value))
+ return port
+end
+
+procedure DISPLAY(value,port)
+ /port := OutputPortStack[1]
+ writes(port.file,Print(value,"display"))
+ return port
+end
+
+procedure NEWLINE(port)
+ /port := OutputPortStack[1]
+ write(port.file)
+ return port
+end
+
+procedure WRITE_CHAR(char,port)
+ /port := OutputPortStack[1]
+ writes(port.file,char.value)
+ return port
+end
diff --git a/ipl/packs/skeem/sklist.icn b/ipl/packs/skeem/sklist.icn
new file mode 100644
index 0000000..58041b0
--- /dev/null
+++ b/ipl/packs/skeem/sklist.icn
@@ -0,0 +1,252 @@
+############################################################################
+#
+# Name: sklist.icn
+#
+# Title: Scheme in Icon
+#
+# Author: Bob Alexander
+#
+# Date: March 23, 1995
+#
+# Description: see skeem.icn
+#
+############################################################################
+
+#
+# skeem -- Scheme in Icon
+#
+# List and vector procedures
+#
+
+#
+# Initialize
+#
+# List entries are described in skfun.icn.
+#
+procedure InitList()
+ DefFunction([
+ APPEND,&null,
+ ASSOC,2,
+ ASSQ,2,
+ ASSV,2,
+ CAR,
+ CDR,
+ CONS,2,
+ CXXR,"CAAR",
+ CXXR,"CADR",
+ CXXR,"CDAR",
+ CXXR,"CDDR",
+ CXXR,"CAAAR",
+ CXXR,"CAADR",
+ CXXR,"CADAR",
+ CXXR,"CADDR",
+ CXXR,"CDAAR",
+ CXXR,"CDADR",
+ CXXR,"CDDAR",
+ CXXR,"CDDDR",
+ CXXR,"CAAAAR",
+ CXXR,"CAAADR",
+ CXXR,"CAADAR",
+ CXXR,"CAADDR",
+ CXXR,"CADAAR",
+ CXXR,"CADADR",
+ CXXR,"CADDAR",
+ CXXR,"CADDDR",
+ CXXR,"CDAAAR",
+ CXXR,"CDAADR",
+ CXXR,"CDADAR",
+ CXXR,"CDADDR",
+ CXXR,"CDDAAR",
+ CXXR,"CDDADR",
+ CXXR,"CDDDAR",
+ CXXR,"CDDDDR",
+ LENGTH,
+ LIST,&null,
+ LIST_2_VECTOR,
+ LIST_P,
+ LIST_REF,2,
+ LIST_TAIL,2,
+ MAKE_VECTOR,1,2,
+ MEMBER,2,
+ MEMQ,2,
+ MEMV,2,
+ NULL_P,
+ PAIR_P,
+ REVERSE,
+ SET_CAR_BANG,2,
+ SET_CDR_BANG,2,
+ VECTOR,&null,
+ VECTOR_2_LIST,
+ VECTOR_FILL_BANG,2,
+ VECTOR_LENGTH,
+ VECTOR_P,
+ VECTOR_REF,2,
+ VECTOR_SET_BANG,3])
+ return
+end
+
+
+#
+# Pairs and lists.
+#
+
+procedure PAIR_P(x)
+ return (LLIsPair(x),T) | F
+end
+
+procedure CONS(first,rest)
+ return LLPair(first,rest)
+end
+
+procedure CAR(pair)
+ return LLFirst(pair)
+end
+
+procedure CDR(pair)
+ return LLRest(pair)
+end
+
+procedure SET_CAR_BANG(pair,value)
+ return LLFirst(pair) := value
+end
+
+procedure SET_CDR_BANG(pair,value)
+ return LLRest(pair) := value
+end
+
+## procedure ArgErr(fName,argList,msg,argNbr)
+## /argNbr := 1
+## return Error(fName,"bad argument ",argNbr,": ",
+## Print(LLElement(argList,argNbr))," -- " || \msg | "")
+## end
+
+procedure CXXR(lst)
+ local result,c
+ result := lst
+ every c := !reverse(FuncName[2:-1]) do {
+ result := (if c == "A" then LLFirst else LLRest)(result)
+ }
+ return result
+end
+
+procedure NULL_P(x)
+ return (LLIsNull(x),T) | F
+end
+
+procedure LIST_P(x)
+ local beenThere
+ beenThere := set()
+ while LLIsPair(x) do {
+ if member(beenThere,x) then break
+ insert(beenThere,x)
+ x := LLRest(x)
+ }
+ return (LLIsNull(x),T) | F
+end
+
+procedure LIST(x[])
+ return LList!x
+end
+
+procedure LENGTH(lst)
+ return LLLength(lst)
+end
+
+procedure APPEND(lst[])
+ return LLAppend!lst
+end
+
+procedure REVERSE(lst)
+ return LLReverse(lst)
+end
+
+procedure LIST_TAIL(lst,i)
+ return LLTail(lst,i + 1)
+end
+
+procedure LIST_REF(lst,i)
+ return LLElement(lst,i + 1)
+end
+
+invocable "===":2
+
+procedure MEMQ(lst,x)
+ static eq
+ initial eq := proc("===",2)
+ return Member(eq,lst,x) | F
+end
+
+procedure MEMV(lst,x)
+ return Member(Eqv,lst,x) | F
+end
+
+procedure MEMBER(lst,x)
+ return Member(Equal,lst,x) | F
+end
+
+procedure Member(test,obj,L)
+ return if /L then fail else (test(obj,LLFirst(L)),L) | Member(test,obj,LLRest(L))
+end
+
+invocable "===":2
+
+procedure ASSQ(alst,x)
+ static eq
+ initial eq := proc("===",2)
+ return Assoc(eq,alst,x) | F
+end
+
+procedure ASSV(alst,x)
+ return Assoc(Eqv,alst,x) | F
+end
+
+procedure ASSOC(alst,x)
+ return Assoc(Equal,alst,x) | F
+end
+
+procedure Assoc(test,obj,L)
+ return if /L then fail else (test(obj,LLFirst(LLFirst(L))),LLFirst(L)) |
+ Assoc(test,obj,LLRest(L))
+end
+
+
+#
+# Vectors
+#
+
+procedure VECTOR_P(x)
+ return (VectorP(x),T) | F
+end
+
+procedure MAKE_VECTOR(len,value[])
+ return list(len,value[1] | F)
+end
+
+procedure VECTOR(x[])
+ return x
+end
+
+procedure VECTOR_LENGTH(vec)
+ return *vec
+end
+
+procedure VECTOR_REF(vec,i)
+ return vec[i + 1]
+end
+
+procedure VECTOR_SET_BANG(vec,i,value)
+ return vec[i + 1] := value
+end
+
+procedure VECTOR_2_LIST(vec)
+ return LList!vec
+end
+
+procedure LIST_2_VECTOR(lst)
+ return LLToList(lst)
+end
+
+procedure VECTOR_FILL_BANG(vec,value)
+ every !vec := value
+ return vec
+end
diff --git a/ipl/packs/skeem/skmisc.icn b/ipl/packs/skeem/skmisc.icn
new file mode 100644
index 0000000..afd0f9a
--- /dev/null
+++ b/ipl/packs/skeem/skmisc.icn
@@ -0,0 +1,128 @@
+############################################################################
+#
+# Name: skmisc.icn
+#
+# Title: Scheme in Icon
+#
+# Author: Bob Alexander
+#
+# Date: March 23, 1995
+#
+# Description: see skeem.icn
+#
+############################################################################
+
+#
+# skeem -- Scheme in Icon
+#
+# Various procedures:
+#
+# Booleans
+# Equivalence predicates
+# Symbols
+# System interface
+#
+
+#
+# Initialize
+#
+# List entries are described in skfun.icn.
+#
+procedure InitMisc()
+ DefFunction([
+ BOOLEAN_P,
+ EQUAL_P,2,
+ EQV_P,2,
+ EQ_P,2,
+ LOAD,
+ NOT,
+ STRING_2_SYMBOL,
+ SYMBOL_2_STRING,
+ SYMBOL_P])
+ return
+end
+
+
+#
+# Booleans
+#
+
+procedure NOT(bool)
+ return (F === bool,T) | F
+end
+
+procedure BOOLEAN_P(x)
+ return (x === (T | F),T) | F
+end
+
+
+#
+# Equivalence predicates
+#
+
+procedure EQV_P(x1,x2)
+ return (Eqv(x1,x2),T) | F
+end
+
+procedure EQ_P(x1,x2)
+ return (x1 === x2,T) | F
+end
+
+procedure EQUAL_P(x1,x2)
+ return (Equal(x1,x2),T) | F
+end
+
+procedure Eqv(x1,x2)
+ local t1,t2
+ t1 := type(x1)
+ t2 := type(x2)
+ return {
+ if not (("integer" | "real") ~== (t1 | t2)) then x1 = x2
+ else if not ("Char" ~== (t1 | t2)) then x1.value == x2.value
+ else x1 === x2
+ }
+end
+
+procedure Equal(x1,x2)
+ local t1,t2,i
+ return Eqv(x1,x2) | {
+ case (t1 := type(x1)) == (t2 := type(x2)) of {
+ "LLPair": Equal(LLFirst(x1),LLFirst(x2)) & Equal(LLRest(x1),LLRest(x2))
+ "list": {
+ not (every i := 1 to (*x1 == *x2) do
+ if not Equal(x1[i],x2[i]) then break)
+ }
+ "String": x1.value == x2.value
+ }
+ }
+end
+
+
+#
+# Symbols
+#
+
+procedure SYMBOL_P(x)
+ return (SymbolP(x),T) | F
+end
+
+procedure SYMBOL_2_STRING(sym)
+ return String(sym)
+end
+
+procedure STRING_2_SYMBOL(s)
+ return s.value
+end
+
+
+#
+# System interface
+#
+
+procedure LOAD(file)
+ local result,f
+ f := OpenFile(file,"r",LOAD) | fail
+ result := ReadEvalPrint(f,"quiet") | Failure
+ close(f)
+ return Failure ~=== result
+end
diff --git a/ipl/packs/skeem/sknumber.icn b/ipl/packs/skeem/sknumber.icn
new file mode 100644
index 0000000..fcdda52
--- /dev/null
+++ b/ipl/packs/skeem/sknumber.icn
@@ -0,0 +1,440 @@
+############################################################################
+#
+# Name: sknumber.icn
+#
+# Title: Scheme in Icon
+#
+# Author: Bob Alexander
+#
+# Date: March 23, 1995
+#
+# Description: see skeem.icn
+#
+############################################################################
+
+#
+# skeem -- Scheme in Icon
+#
+# Number procedures
+#
+
+#
+# Initialize
+#
+# List entries are described in skfun.icn.
+#
+procedure InitNumber()
+ DefFunction([
+ ABS,
+ ACOS,
+ ADD,&null,"+",
+ ASIN,
+ ATAN,1,2,
+ CEILING,
+ COMPLEX_P,
+ COS,
+ DIVIDE,"oneOrMore","/",
+ EQ,"twoOrMore","=",
+ EVEN_P,
+ EXACT_2_INEXACT,
+ EXACT_P,
+ EXP,
+ EXPT,2,
+ FLOOR,
+ GCD,&null,
+ GE,"twoOrMore",">=",
+ GT,"twoOrMore",">",
+ INEXACT_2_EXACT,
+ INEXACT_P,
+ INTEGER_P,
+ LCM,&null,
+ LE,"twoOrMore","<=",
+ LOG,
+ LT,"twoOrMore","<",
+ MAX,"oneOrMore",
+ MIN,"oneOrMore",
+ MODULO,2,
+ MULTIPLY,&null,"*",
+ NE,"twoOrMore","<>",
+ NEGATIVE_P,
+ NUMBER_2_STRING,1,2,
+ NUMBER_P,
+ ODD_P,
+ POSITIVE_P,
+ QUOTIENT,2,
+ RATIONAL_P,
+ REAL_P,
+ REMAINDER,2,
+ ROUND,
+ SIN,
+ SQRT,
+ STRING_2_NUMBER,1,2,
+ SUBTRACT,"oneOrMore","-",
+ TAN,
+ TRUNCATE,
+ ZERO_P])
+ return
+end
+
+
+#
+# Numbers
+#
+
+procedure NUMBER_P(x)
+ return REAL_P(x)
+end
+
+procedure COMPLEX_P(x)
+ return REAL_P(x)
+end
+
+procedure REAL_P(x)
+ return (type(x) == ("integer" | "real"),T) | F
+end
+
+procedure RATIONAL_P(x)
+ return INTEGER_P(x)
+end
+
+procedure INTEGER_P(x)
+ return (type(x) == "integer",T) | F
+end
+
+procedure EXACT_P(x)
+ return (type(numeric(x)) == "real",F) | T
+end
+
+procedure INEXACT_P(x)
+ return (type(numeric(x)) == "real",T) | F
+end
+
+invocable "<":2
+
+procedure LT(n[])
+ static op
+ initial op := proc("<",2)
+ return NumericPredicate(n,op)
+end
+
+invocable "<=":2
+
+procedure LE(n[])
+ static op
+ initial op := proc("<=",2)
+ return NumericPredicate(n,op)
+end
+
+invocable "=":2
+
+procedure EQ(n[])
+ static op
+ initial op := proc("=",2)
+ return NumericPredicate(n,op)
+end
+
+invocable ">=":2
+
+procedure GE(n[])
+ static op
+ initial op := proc(">=",2)
+ return NumericPredicate(n,op)
+end
+
+invocable ">":2
+
+procedure GT(n[])
+ static op
+ initial op := proc(">",2)
+ return NumericPredicate(n,op)
+end
+
+invocable "~=":2
+
+procedure NE(n[])
+ static op
+ initial op := proc("~=",2)
+ return NumericPredicate(n,op)
+end
+
+procedure ZERO_P(n)
+ return (n = 0,T) | F
+end
+
+procedure POSITIVE_P(n)
+ return (n > 0,T) | F
+end
+
+procedure NEGATIVE_P(n)
+ return (n < 0,T) | F
+end
+
+procedure ODD_P(n)
+ return (n % 2 ~= 0,T) | F
+end
+
+procedure EVEN_P(n)
+ return (n % 2 = 0,T) | F
+end
+
+procedure MAX(n[])
+ local result,x
+ result := get(n)
+ every x := !n do {
+ if type(x) == "real" then result := real(result)
+ result <:= x
+ }
+ return result
+end
+
+procedure MIN(n[])
+ local result,x
+ result := get(n)
+ every x := !n do {
+ if type(x) == "real" then result := real(result)
+ result >:= x
+ }
+ return result
+end
+
+invocable "+":2,"+":1
+
+procedure ADD(n[])
+ static op,op1
+ initial {
+ op := proc("+",2)
+ op1 := proc("+",1)
+ }
+ return Arithmetic(n,op,op1,0)
+end
+
+invocable "*":2,"+":1
+
+procedure MULTIPLY(n[])
+ static op,op1
+ initial {
+ op := proc("*",2)
+ op1 := proc("+",1)
+ }
+ return Arithmetic(n,op,op1,1)
+end
+
+invocable "-":2,"-":1
+
+procedure SUBTRACT(n[])
+ static op,op1
+ initial {
+ op := proc("-",2)
+ op1 := proc("-",1)
+ }
+ return Arithmetic(n,op,op1)
+end
+
+procedure DIVIDE(n[])
+ return Arithmetic(n,Divide,Reciprocal)
+end
+
+procedure Divide(n1,n2)
+ return n1 / ZeroDivCheck(DIVIDE,n2)
+end
+
+procedure Reciprocal(n)
+ return Divide(1.0,n)
+end
+
+procedure ZeroDivCheck(fName,n)
+ return if n = 0 then Error(fName,"divide by zero") else n
+end
+
+procedure ABS(n)
+ return abs(n)
+end
+
+procedure QUOTIENT(num,den)
+ return integer(num) / ZeroDivCheck(QUOTIENT,integer(den))
+end
+
+procedure REMAINDER(num,den)
+ return num % ZeroDivCheck(REMAINDER,den)
+end
+
+procedure MODULO(num,den)
+ local result
+ result := num % ZeroDivCheck(REMAINDER,den)
+ if result ~= 0 then
+ result +:= if 0 > num then 0 <= den else 0 > den
+ return result
+end
+
+procedure GCD(n[])
+ local min,i,areal,x
+ min := 0 < abs(!n)
+ if /min then return 0
+ every i := 1 to *n do {
+ x := numeric(n[i])
+ areal := type(x) == "real"
+ min >:= 0 < (n[i] := abs(x))
+ }
+ x := ((every i := min to 2 by -1 do !n % i ~= 0 | break),i) | 1
+ return (\areal,real(x)) | x
+end
+
+procedure LCM(n[])
+ local max,i,areal,x
+ max := 0
+ every i := 1 to *n do {
+ x := numeric(n[i])
+ areal := type(x) == "real"
+ max <:= n[i] := abs(x)
+ }
+ if max = 0 then return 1
+ x := ((every i := seq(max,max) do i % !n ~= 0 | break),i)
+ return (\areal,real(x)) | x
+end
+
+procedure FLOOR(n)
+ local intn
+ if type(n) == "integer" then return n
+ intn := integer(n)
+ return real(if n < 0.0 & n ~= intn then intn - 1 else intn)
+end
+
+procedure CEILING(n)
+ local intn
+ if type(n) == "integer" then return n
+ intn := integer(n)
+ return real(if n > 0.0 & n ~= intn then intn + 1 else intn)
+end
+
+procedure TRUNCATE(n)
+ return (type(n) == "integer",n) | real(integer(n))
+end
+
+procedure ROUND(n)
+ return (
+ if type(n) == "integer" then n
+ else real(Round(n)))
+end
+
+procedure Round(n)
+ local intn,diff
+ intn := integer(n)
+ diff := abs(n) - abs(intn)
+ return (
+ if diff < 0.5 then intn
+ else if diff > 0.5 then
+ if n < 0.0 then intn - 1
+ else intn + 1
+ else if intn % 2 = 0 then
+ intn
+ else if n < 0.0 then
+ intn - 1
+ else
+ intn + 1)
+end
+
+procedure EXP(n)
+ return exp(n)
+end
+
+procedure LOG(n)
+ return log(n)
+end
+
+procedure SIN(n)
+ return sin(n)
+end
+
+procedure COS(n)
+ return cos(n)
+end
+
+procedure TAN(n)
+ return tan(n)
+end
+
+procedure ASIN(n)
+ return asin(n)
+end
+
+procedure ACOS(n)
+ return acos(n)
+end
+
+procedure ATAN(num,den)
+ return atan(num,den)
+end
+
+procedure SQRT(n)
+ return sqrt(n)
+end
+
+procedure EXPT(n1,n2)
+ return n1 ^ n2
+end
+
+procedure EXACT_2_INEXACT(n)
+ return real(n)
+end
+
+procedure INEXACT_2_EXACT(n)
+ return Round(n)
+end
+
+
+#
+# Numerical input and output.
+#
+
+procedure STRING_2_NUMBER(s,rx)
+ return StringToNumber(s.value,rx) | F
+end
+
+procedure NUMBER_2_STRING(n,rx)
+ return String(
+ if \rx ~= 10 then
+ AsRadix(n,rx)
+ else
+ string(n)
+ ) | Error(NUMBER_2_STRING,"can't convert")
+end
+
+#
+# Procedure to return print representation of a number in specified
+# radix (2 - 36).
+#
+procedure AsRadix(i,radix)
+ local result,sign
+ static digits
+ initial digits := &digits || &lcase
+ if radix <= 1 then runerr(205,radix)
+ if i = 0 then return "0"
+ sign := (i < 0,"-") | ""
+ i := abs(i)
+ result := ""
+ until i = 0 do {
+ result := (digits[i % radix + 1] | fail) || result
+ i /:= radix
+ }
+ return sign || result
+end
+
+procedure Arithmetic(nList,op,op1,zeroArgValue)
+ local result,x
+ if not nList[1] then return \zeroArgValue
+ if not nList[2] & \op1 then return op1(nList[1])
+ else {
+ result := get(nList)
+ every x := !nList do
+ result := op(result,x) | fail
+ return result
+ }
+end
+
+procedure NumericPredicate(nList,op)
+ local result,x
+ result := get(nList)
+ every x := !nList do
+ result := op(result,x) | (if &errornumber then fail else return F)
+ return T
+end
diff --git a/ipl/packs/skeem/skout.icn b/ipl/packs/skeem/skout.icn
new file mode 100644
index 0000000..ec1382b
--- /dev/null
+++ b/ipl/packs/skeem/skout.icn
@@ -0,0 +1,105 @@
+############################################################################
+#
+# Name: skout.icn
+#
+# Title: Scheme in Icon
+#
+# Author: Bob Alexander
+#
+# Date: February 19, 1995
+#
+# Description: see skeem.icn
+#
+############################################################################
+
+#
+# skeem -- Scheme in Icon
+#
+# Output utility procedures
+#
+
+procedure Print(x,display)
+ local s,node,sep
+ static symFirst,symRest
+ initial {
+ symFirst := &ucase ++ '!$%&*/:<=>?~_^'
+ symRest := symFirst ++ &digits ++ '.+-'
+ }
+ return {
+ if LLIsNull(x) then "()"
+ else if LLIsPair(x) then {
+ s := "("
+ sep := ""
+ every node := LLPairs(x) do {
+ s ||:= sep || Print(LLFirst(node),display)
+ sep := " "
+ }
+ s ||:= if LLIsNull(LLRest(node)) then ")"
+ else " . " || Print(LLRest(node),display) || ")"
+ }
+ else if x === T then "#t"
+ else if x === F then "#f"
+ else if x === Unbound then "#<unbound>"
+ else if x === EOFObject then "#<eof>"
+ else if type(x) == "Promise" then "#<promise>"
+ else if type(x) == "Port" then "#<" ||
+ (if find("w",x.option) then "output " else "input ") ||
+ image(x.file) || ">"
+ else if VectorP(x) then {
+ s := "#("
+ sep := ""
+ every node := !x do {
+ s ||:= sep || Print(node,display)
+ sep := " "
+ }
+ s ||:= ")"
+ }
+ else if s := case type(x) of {
+ "Function": PrintFunction(x,"built-in function")
+ "Lambda": PrintFunction(x,"interpreted function")
+ "Macro": PrintFunction(x,"macro")
+ "Syntax": PrintFunction(x,"syntax")
+ } then s
+ else if StringP(x) then if \display then x.value else image(x.value)
+ else if CharP(x) then if \display then x.value else {
+ "#\\" || (case x.value of {
+ " ": "space"
+ "\t": "tab"
+ "\n": "newline"
+ "\b": "backspace"
+ "\d": "delete"
+ "\e": "escape"
+ "\f": "formfeed"
+ "\r": "return"
+ "\v": "verticaltab"
+ default: x.value
+ })
+ }
+ else if SymbolP(x) then if \display then x else {
+ (x ? ((=("+" | "-" | "...") |
+ (tab(any(symFirst)) & tab(many(symRest)) | &null)) &
+ pos(0)),x) | {
+ x ? {
+ s := ""
+ while s ||:= tab(upto('|\\')) do s ||:= case move(1) of {
+ "|": "\\|"
+ default: "\\\\"
+ }
+ s ||:= tab(0)
+ }
+ "|" || s || "|"
+ }
+ }
+ else if numeric(x) then string(x)
+ else "#<Icon(" || image(x) || ")>"
+ }
+end
+
+procedure PrintFunction(fun,fType)
+ local p
+ return case type(p := fun.proc) of {
+ "LLPair": "#<" || fType || " " || (\fun.name | "???") || ">"
+ "procedure": "#<" || image(p) || ">"
+ default: runerr(500,type(p))
+ }
+end
diff --git a/ipl/packs/skeem/skstring.icn b/ipl/packs/skeem/skstring.icn
new file mode 100644
index 0000000..d4cc8cc
--- /dev/null
+++ b/ipl/packs/skeem/skstring.icn
@@ -0,0 +1,360 @@
+############################################################################
+#
+# Name: skstring.icn
+#
+# Title: Scheme in Icon
+#
+# Author: Bob Alexander
+#
+# Date: March 23, 1995
+#
+# Description: see skeem.icn
+#
+############################################################################
+
+#
+# skeem -- Scheme in Icon
+#
+# String and character procedures
+#
+
+#
+# Initialize
+#
+# List entries are described in skfun.icn.
+#
+procedure InitString()
+ DefFunction([
+ CHAR_2_INTEGER,
+ CHAR_ALPHABETIC_P,
+ CHAR_CI_EQ,"twoOrMore","CHAR-CI=?",
+ CHAR_CI_GE,"twoOrMore","CHAR-CI>=?",
+ CHAR_CI_GT,"twoOrMore","CHAR-CI>?",
+ CHAR_CI_LE,"twoOrMore","CHAR-CI<=?",
+ CHAR_CI_LT,"twoOrMore","CHAR-CI<?",
+ CHAR_CI_NE,"twoOrMore","CHAR-CI<>?",
+ CHAR_DOWNCASE,
+ CHAR_EQ,"twoOrMore","CHAR=?",
+ CHAR_GE,"twoOrMore","CHAR>=?",
+ CHAR_GT,"twoOrMore","CHAR>?",
+ CHAR_LE,"twoOrMore","CHAR<=?",
+ CHAR_LOWER_CASE_P,
+ CHAR_LT,"twoOrMore","CHAR<?",
+ CHAR_NE,"twoOrMore","CHAR<>?",
+ CHAR_NUMERIC_P,
+ CHAR_P,
+ CHAR_UPCASE,
+ CHAR_UPPER_CASE_P,
+ CHAR_WHITESPACE_P,
+ INTEGER_2_CHAR,
+ LIST_2_STRING,
+ MAKE_STRING,1,2,
+ STRING,&null,
+ STRING_2_EXPRESSION,
+ STRING_2_LIST,
+ STRING_APPEND,&null,
+ STRING_CI_EQ,"twoOrMore","STRING-CI=?",
+ STRING_CI_GE,"twoOrMore","STRING-CI>=?",
+ STRING_CI_GT,"twoOrMore","STRING-CI>?",
+ STRING_CI_LE,"twoOrMore","STRING-CI<=?",
+ STRING_CI_LT,"twoOrMore","STRING-CI<?",
+ STRING_CI_NE,"twoOrMore","STRING-CI<>?",
+ STRING_COPY,
+ STRING_EQ,"twoOrMore","STRING=?",
+ STRING_FILL_BANG,2,
+ STRING_GE,"twoOrMore","STRING>=?",
+ STRING_GT,"twoOrMore","STRING>?",
+ STRING_LE,"twoOrMore","STRING<=?",
+ STRING_LENGTH,
+ STRING_LT,"twoOrMore","STRING<?",
+ STRING_NE,"twoOrMore","STRING<>?",
+ STRING_P,
+ STRING_REF,2,
+ STRING_SET_BANG,3,
+ SUBSTRING,2,3,
+ SUBSTRING_COPY_BANG,3])
+ return
+end
+
+
+#
+# Characters
+#
+
+procedure CHAR_P(x)
+ return (CharP(x),T) | F
+end
+
+procedure CHAR_LT(c1,c2)
+ return STRING_LT(c1,c2)
+end
+
+procedure CHAR_LE(c1,c2)
+ return STRING_LE(c1,c2)
+end
+
+procedure CHAR_EQ(c1,c2)
+ return STRING_EQ(c1,c2)
+end
+
+procedure CHAR_GE(c1,c2)
+ return STRING_GE(c1,c2)
+end
+
+procedure CHAR_GT(c1,c2)
+ return STRING_GT(c1,c2)
+end
+
+procedure CHAR_NE(c1,c2)
+ return STRING_NE(c1,c2)
+end
+
+procedure CHAR_CI_LT(c1,c2)
+ return STRING_CI_LT(c1,c2)
+end
+
+procedure CHAR_CI_LE(c1,c2)
+ return STRING_CI_LE(c1,c2)
+end
+
+procedure CHAR_CI_EQ(c1,c2)
+ return STRING_CI_EQ(c1,c2)
+end
+
+procedure CHAR_CI_GE(c1,c2)
+ return STRING_CI_GE(c1,c2)
+end
+
+procedure CHAR_CI_GT(c1,c2)
+ return STRING_CI_GT(c1,c2)
+end
+
+procedure CHAR_CI_NE(c1,c2)
+ return STRING_CI_NE(c1,c2)
+end
+
+procedure CHAR_ALPHABETIC_P(c)
+ return (any(&letters,c.value),T) | F
+end
+
+procedure CHAR_NUMERIC_P(c)
+ return (any(&digits,c.value),T) | F
+end
+
+procedure CHAR_WHITESPACE_P(c)
+ return (any(' \n\f\r\l',c.value),T) | F
+end
+
+procedure CHAR_UPPER_CASE_P(c)
+ return (any(&ucase,c.value),T) | F
+end
+
+procedure CHAR_LOWER_CASE_P(c)
+ return (any(&lcase,c.value),T) | F
+end
+
+procedure CHAR_2_INTEGER(c)
+ return ord(c.value)
+end
+
+procedure INTEGER_2_CHAR(c)
+ return Char(char(c))
+end
+
+procedure CHAR_UPCASE(c)
+ return Char(map(c.value,&lcase,&ucase))
+end
+
+procedure CHAR_DOWNCASE(c)
+ return Char(map(c.value,&ucase,&lcase))
+end
+
+
+#
+# Strings
+#
+
+procedure STRING_P(x)
+ return (StringP(x),T) | F
+end
+
+procedure MAKE_STRING(len,c)
+ return String(repl((\c).value | "\0",len))
+end
+
+procedure STRING(c[])
+ local result
+ result := ""
+ every result ||:= (!c).value
+ return String(result)
+end
+
+procedure STRING_LENGTH(s)
+ return *s.value
+end
+
+procedure STRING_REF(s,i)
+ return Char(s.value[i + 1])
+end
+
+procedure STRING_SET_BANG(s,i,c)
+ s.value[i + 1] := c.value
+ return s
+end
+
+invocable "<<":2
+
+procedure STRING_LT(s[])
+ static op
+ initial op := proc("<<",2)
+ return StringPredicate(s,op)
+end
+
+invocable "<<=":2
+
+procedure STRING_LE(s[])
+ static op
+ initial op := proc("<<=",2)
+ return StringPredicate(s,op)
+end
+
+invocable "==":2
+
+procedure STRING_EQ(s[])
+ static op
+ initial op := proc("==",2)
+ return StringPredicate(s,op)
+end
+
+invocable ">>=":2
+
+procedure STRING_GE(s[])
+ static op
+ initial op := proc(">>=",2)
+ return StringPredicate(s,op)
+end
+
+invocable ">>":2
+
+procedure STRING_GT(s[])
+ static op
+ initial op := proc(">>",2)
+ return StringPredicate(s,op)
+end
+
+invocable "~==":2
+
+procedure STRING_NE(s[])
+ static op
+ initial op := proc("~==",2)
+ return StringPredicate(s,op)
+end
+
+invocable "<<":2
+
+procedure STRING_CI_LT(s[])
+ static op
+ initial op := proc("<<",2)
+ return StringPredicateCI(s,op)
+end
+
+invocable "<<=":2
+
+procedure STRING_CI_LE(s[])
+ static op
+ initial op := proc("<<=",2)
+ return StringPredicateCI(s,op)
+end
+
+invocable "==":2
+
+procedure STRING_CI_EQ(s[])
+ static op
+ initial op := proc("==",2)
+ return StringPredicateCI(s,op)
+end
+
+invocable ">>=":2
+
+procedure STRING_CI_GE(s[])
+ static op
+ initial op := proc(">>=",2)
+ return StringPredicateCI(s,op)
+end
+
+invocable ">>":2
+
+procedure STRING_CI_GT(s[])
+ static op
+ initial op := proc(">>",2)
+ return StringPredicateCI(s,op)
+end
+
+invocable "~==":2
+
+procedure STRING_CI_NE(s[])
+ static op
+ initial op := proc("~==",2)
+ return StringPredicateCI(s,op)
+end
+
+procedure SUBSTRING(s,i,j)
+ return String(s.value[i + 1:\j + 1 | 0]) |
+ Error(SUBSTRING,"indices out of range")
+end
+
+procedure STRING_APPEND(s[])
+ local result
+ result := get(s).value | ""
+ every result ||:= (!s).value
+ return String(result)
+end
+
+procedure STRING_2_LIST(s)
+ local result
+ result := LLNull
+ every result := LLPair(Char(!s.value),result)
+ return LLInvert(result)
+end
+
+procedure LIST_2_STRING(lst)
+ return STRING!LLToList(lst)
+end
+
+procedure STRING_COPY(s)
+ return copy(s)
+end
+
+procedure STRING_FILL_BANG(s,c)
+ s.value := repl(c.value,*s.value)
+ return s
+end
+
+procedure STRING_2_EXPRESSION(s)
+ return StringToExpr(s.value) | F
+end
+
+procedure SUBSTRING_COPY_BANG(s1,k,s2)
+ local s2v,copyLen
+ s2v := s2.value
+ copyLen := *s1.value - k
+ copyLen >:= *s2v
+ s1.value[k + 1+:copyLen] := s2v
+ return s1
+end
+
+procedure StringPredicate(sList,op)
+ local result,x
+ result := get(sList).value
+ every x := (!sList).value do
+ result := op(result,x) | (if &errornumber then fail else return F)
+ return T
+end
+
+procedure StringPredicateCI(sList,op)
+ local result,x
+ result := map(get(sList).value)
+ every x := map((!sList).value) do
+ result := op(result,x) | (if &errornumber then fail else return F)
+ return T
+end
diff --git a/ipl/packs/skeem/skuser.icn b/ipl/packs/skeem/skuser.icn
new file mode 100644
index 0000000..0dc9901
--- /dev/null
+++ b/ipl/packs/skeem/skuser.icn
@@ -0,0 +1,45 @@
+############################################################################
+#
+# Name: skuser.icn
+#
+# Title: Scheme in Icon
+#
+# Author: Bob Alexander
+#
+# Date: March 23, 1995
+#
+# Description: see skeem.icn
+#
+############################################################################
+
+#
+# skeem -- Scheme in Icon
+#
+# Initialization list for user-defined functions
+#
+
+#
+# Initialize
+#
+procedure InitUser()
+ #
+ # List of user-defined inialization functions to call at
+ # skeem-initialization-time.
+ #
+ # Add entries to this list for your user-defined primitive functions
+ # and syntaxes.
+ #
+ # Null entries are okay. The list is primed with the following
+ # entries:
+ #
+ # - InitExtra: Some extra functions and syntaxes that are not
+ # in the Scheme standard.
+ #
+ # - InitUser: An entry for an initialization function that can
+ # be provided by a user (InitUser is not defined in
+ # skeem).
+ #
+ return [
+ InitExtra, # extra functions provided -- skextra.icn
+ InitUser] # user-defined primitive functions (not provided)
+end
diff --git a/ipl/packs/skeem/skutil.icn b/ipl/packs/skeem/skutil.icn
new file mode 100644
index 0000000..0c59532
--- /dev/null
+++ b/ipl/packs/skeem/skutil.icn
@@ -0,0 +1,206 @@
+############################################################################
+#
+# Name: skutil.icn
+#
+# Title: Scheme in Icon
+#
+# Author: Bob Alexander
+#
+# Date: February 19, 1995
+#
+# Description: see skeem.icn
+#
+############################################################################
+
+#
+# skeem -- Scheme in Icon
+#
+# Miscellaneous utility procedures
+#
+
+#
+# Eval()
+#
+procedure Eval(ex,env)
+ local saveEnv,result
+ if LLIsNull(ex) then return NIL
+ saveEnv := CurrentEnv
+ CurrentEnv := \env
+ result := Eval1(ex) | Failure
+ CurrentEnv := saveEnv
+ return Failure ~=== result
+end
+
+procedure Eval1(ex)
+ local fcn,arg
+ return {
+ if LLIsNotPair(ex) then {
+ if SymbolP(ex) then
+ GetVar(ex) | Error(ex,"unbound variable")
+ else ex
+ }
+ else {
+ fcn := Eval(LLFirst(ex)) | fail
+ arg := LLRest(ex)
+ if type(fcn) == ("Function" | "Lambda") then
+ arg := EvLList(arg) | fail
+ Apply(fcn,arg)
+ }
+ }
+end
+
+procedure Apply(fcn,arg)
+ local value,fName,traced,fProc,oldFName,argList
+ oldFName := FuncName
+ FuncName := fName := \fcn.name | "<anonymous function>"
+ if traced := \(FTrace | fcn.traced) then
+ write(repl(" ",&level),Print(LLPair(fName,arg)))
+ fProc := fcn.proc
+ (value := case type(fcn) of {
+ "Function" | "Syntax": {
+ argList := LLToList(arg)
+ CheckArgs(fcn,*argList) &
+ fProc!argList
+ }
+ "Lambda": {
+ CheckArgs(fcn,LLLength(arg)) &
+ DoLambda(fProc,arg,fcn.env)
+ }
+ "Macro": {
+ CheckArgs(fcn,LLLength(arg)) &
+ Eval(DoLambda(fProc,arg,fcn.env))
+ }
+ default: Error("Invoke",Print(fcn),": can't invoke as function")
+ }) | {/FailProc := fName; fail}
+ if \traced then
+ write(repl(" ",&level),fName," -> ",Print(value))
+ FuncName := oldFName
+ return value
+end
+
+#
+# DoLambda() - Invoke a lambda-defined function.
+#
+procedure DoLambda(def,actuals,env)
+ local result,arg,p,saveEnv,formals
+ formals := LLFirst(def)
+ saveEnv := CurrentEnv
+ CurrentEnv := \env
+ PushFrame()
+ if LLIsList(formals) then {
+ p := actuals
+ every DefVar(LLFirst(arg := LLPairs(formals)),LLFirst(p)) do
+ p := LLRest(p)
+ DefVar(\LLRest(arg),p)
+ }
+ else DefVar(formals,actuals)
+ result := EvalSeq(LLRest(def)) | {CurrentEnv := saveEnv; fail}
+ CurrentEnv := saveEnv
+ return result
+end
+
+procedure CheckArgs(fcn,nbrArgs)
+ return if fcn.minArgs > nbrArgs then Error(fcn.name,"too few args")
+ else if \fcn.maxArgs < nbrArgs then Error(fcn.name,"too many args")
+ else nbrArgs
+end
+
+procedure EvalSeq(L)
+ local value,element
+ if /L then fail
+ every element := LLElements(L) do
+ value := Eval(element) | fail
+ return value
+end
+
+#
+# EvList() - Evaluate everything in a list, producing an Icon list.
+#
+procedure EvList(L)
+ local arglist,arg
+ arglist := []
+ every arg := LLElements(L) do
+ put(arglist,Eval(arg)) | fail
+ return arglist
+end
+
+#
+# EvLList() - Evaluate everything in a list, producing a LList.
+#
+procedure EvLList(L)
+ local arglist,arg
+ arglist := LLNull
+ every arg := LLElements(L) do
+ arglist := LLPair(Eval(arg),arglist) | fail
+ return LLInvert(arglist)
+end
+
+#
+# Retrieve a bound variable value, failing if none.
+#
+procedure GetVar(sym,env)
+ /env := CurrentEnv
+ return Unbound ~=== LLElements(env)[sym]
+end
+
+#
+# Set a currently bound variable, failing if none.
+#
+procedure SetVar(sym,value,env)
+ local frame
+ /env := CurrentEnv
+ return if Unbound ~=== (frame := LLElements(env))[sym] then
+ .(frame[sym] := value)
+end
+
+#
+# Define and set a variable in the specified environment (default current env).
+#
+procedure DefVar(sym,value,env)
+ /env := CurrentEnv
+ return .(LLFirst(env)[sym] := value)
+end
+
+procedure UndefVar(sym,env)
+ /env := CurrentEnv
+ delete(LLFirst(env),sym)
+ return
+end
+
+procedure PushFrame(env)
+ /env := table(Unbound)
+ return .(CurrentEnv := LLPair(env,CurrentEnv))
+end
+
+procedure PopFrame()
+ return 1(LLFirst(CurrentEnv),CurrentEnv := LLRest(CurrentEnv))
+end
+
+procedure DiscardFrame()
+ CurrentEnv := LLRest(CurrentEnv)
+ return
+end
+
+procedure Error(tag,s[])
+ if type(tag) == "procedure" then tag := ProcName(tag)
+ writes(&errout,"\n### Error: ")
+ writes(&errout,\tag," -- ")
+ every writes(&errout,!s)
+ write(&errout)
+end
+
+procedure SymbolP(x)
+ return (type(x) == "string",x)
+end
+
+procedure VectorP(x)
+ return (type(x) == "list",x)
+end
+
+procedure StringP(x)
+ return (type(x) == "String",x)
+end
+
+procedure CharP(x)
+ return (type(x) == "Char",x)
+end
diff --git a/ipl/packs/skeem/test.scm b/ipl/packs/skeem/test.scm
new file mode 100644
index 0000000..727b584
--- /dev/null
+++ b/ipl/packs/skeem/test.scm
@@ -0,0 +1,979 @@
+;;;; `test.scm' Test correctness of scheme implementations.
+;;; Copyright (C) 1991, 1992, 1993, 1994, 1995 Aubrey Jaffer.
+
+;;; This includes examples from
+;;; William Clinger and Jonathan Rees, editors.
+;;; Revised^4 Report on the Algorithmic Language Scheme
+;;; and the IEEE specification.
+
+;;; The input tests read this file expecting it to be named "test.scm".
+;;; Files `tmp1', `tmp2' and `tmp3' will be created in the course of running
+;;; these tests. You may need to delete them in order to run
+;;; "test.scm" more than once.
+
+;;; There are three optional tests:
+;;; (TEST-CONT) tests multiple returns from call-with-current-continuation
+;;;
+;;; (TEST-SC4) tests procedures required by R4RS but not by IEEE
+;;;
+;;; (TEST-DELAY) tests DELAY and FORCE, which are not required by
+;;; either standard.
+
+;;; If you are testing a R3RS version which does not have `list?' do:
+;;; (define list? #f)
+
+;;; send corrections or additions to jaffer@ai.mit.edu or
+;;; Aubrey Jaffer, 84 Pleasant St., Wakefield MA 01880, USA
+
+(define cur-section '())(define errs '())
+(define SECTION (lambda args
+ (display "SECTION") (write args) (newline)
+ (set! cur-section args) #t))
+(define record-error (lambda (e) (set! errs (cons (list cur-section e) errs))))
+
+(define test
+ (lambda (expect fun . args)
+ (write (cons fun args))
+ (display " ==> ")
+ ((lambda (res)
+ (write res)
+ (newline)
+ (cond ((not (equal? expect res))
+ (record-error (list res expect (cons fun args)))
+ (display " BUT EXPECTED ")
+ (write expect)
+ (newline)
+ #f)
+ (else #t)))
+ (if (procedure? fun) (apply fun args) (car args)))))
+(define (report-errs)
+ (newline)
+ (if (null? errs) (display "Passed all tests")
+ (begin
+ (display "errors were:")
+ (newline)
+ (display "(SECTION (got expected (call)))")
+ (newline)
+ (for-each (lambda (l) (write l) (newline))
+ errs)))
+ (newline))
+
+(SECTION 2 1);; test that all symbol characters are supported.
+'(+ - ... !.. $.+ %.- &.! *.: /:. :+. <-. =. >. ?. ~. _. ^.)
+
+(SECTION 3 4)
+(define disjoint-type-functions
+ (list boolean? char? null? number? pair? procedure? string? symbol? vector?))
+(define type-examples
+ (list
+ #t #f #\a '() 9739 '(test) record-error "test" "" 'test '#() '#(a b c) ))
+(define i 1)
+(for-each (lambda (x) (display (make-string i #\ ))
+ (set! i (+ 3 i))
+ (write x)
+ (newline))
+ disjoint-type-functions)
+(define type-matrix
+ (map (lambda (x)
+ (let ((t (map (lambda (f) (f x)) disjoint-type-functions)))
+ (write t)
+ (write x)
+ (newline)
+ t))
+ type-examples))
+(SECTION 4 1 2)
+(test '(quote a) 'quote (quote 'a))
+(test '(quote a) 'quote ''a)
+(SECTION 4 1 3)
+(test 12 (if #f + *) 3 4)
+(SECTION 4 1 4)
+(test 8 (lambda (x) (+ x x)) 4)
+(define reverse-subtract
+ (lambda (x y) (- y x)))
+(test 3 reverse-subtract 7 10)
+(define add4
+ (let ((x 4))
+ (lambda (y) (+ x y))))
+(test 10 add4 6)
+(test '(3 4 5 6) (lambda x x) 3 4 5 6)
+(test '(5 6) (lambda (x y . z) z) 3 4 5 6)
+(SECTION 4 1 5)
+(test 'yes 'if (if (> 3 2) 'yes 'no))
+(test 'no 'if (if (> 2 3) 'yes 'no))
+(test '1 'if (if (> 3 2) (- 3 2) (+ 3 2)))
+(SECTION 4 1 6)
+(define x 2)
+(test 3 'define (+ x 1))
+(set! x 4)
+(test 5 'set! (+ x 1))
+(SECTION 4 2 1)
+(test 'greater 'cond (cond ((> 3 2) 'greater)
+ ((< 3 2) 'less)))
+(test 'equal 'cond (cond ((> 3 3) 'greater)
+ ((< 3 3) 'less)
+ (else 'equal)))
+(test 2 'cond (cond ((assv 'b '((a 1) (b 2))) => cadr)
+ (else #f)))
+(test 'composite 'case (case (* 2 3)
+ ((2 3 5 7) 'prime)
+ ((1 4 6 8 9) 'composite)))
+(test 'consonant 'case (case (car '(c d))
+ ((a e i o u) 'vowel)
+ ((w y) 'semivowel)
+ (else 'consonant)))
+(test #t 'and (and (= 2 2) (> 2 1)))
+(test #f 'and (and (= 2 2) (< 2 1)))
+(test '(f g) 'and (and 1 2 'c '(f g)))
+(test #t 'and (and))
+(test #t 'or (or (= 2 2) (> 2 1)))
+(test #t 'or (or (= 2 2) (< 2 1)))
+(test #f 'or (or #f #f #f))
+(test #f 'or (or))
+(test '(b c) 'or (or (memq 'b '(a b c)) (+ 3 0)))
+(SECTION 4 2 2)
+(test 6 'let (let ((x 2) (y 3)) (* x y)))
+(test 35 'let (let ((x 2) (y 3)) (let ((x 7) (z (+ x y))) (* z x))))
+(test 70 'let* (let ((x 2) (y 3)) (let* ((x 7) (z (+ x y))) (* z x))))
+(test #t 'letrec (letrec ((even?
+ (lambda (n) (if (zero? n) #t (odd? (- n 1)))))
+ (odd?
+ (lambda (n) (if (zero? n) #f (even? (- n 1))))))
+ (even? 88)))
+(define x 34)
+(test 5 'let (let ((x 3)) (define x 5) x))
+(test 34 'let x)
+(test 6 'let (let () (define x 6) x))
+(test 34 'let x)
+(test 7 'let* (let* ((x 3)) (define x 7) x))
+(test 34 'let* x)
+(test 8 'let* (let* () (define x 8) x))
+(test 34 'let* x)
+(test 9 'letrec (letrec () (define x 9) x))
+(test 34 'letrec x)
+(test 10 'letrec (letrec ((x 3)) (define x 10) x))
+(test 34 'letrec x)
+(SECTION 4 2 3)
+(define x 0)
+(test 6 'begin (begin (set! x 5) (+ x 1)))
+(SECTION 4 2 4)
+(test '#(0 1 2 3 4) 'do (do ((vec (make-vector 5))
+ (i 0 (+ i 1)))
+ ((= i 5) vec)
+ (vector-set! vec i i)))
+(test 25 'do (let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum))))
+(test 1 'let (let foo () 1))
+(test '((6 1 3) (-5 -2)) 'let
+ (let loop ((numbers '(3 -2 1 6 -5))
+ (nonneg '())
+ (neg '()))
+ (cond ((null? numbers) (list nonneg neg))
+ ((negative? (car numbers))
+ (loop (cdr numbers)
+ nonneg
+ (cons (car numbers) neg)))
+ (else
+ (loop (cdr numbers)
+ (cons (car numbers) nonneg)
+ neg)))))
+(SECTION 4 2 6)
+(test '(list 3 4) 'quasiquote `(list ,(+ 1 2) 4))
+(test '(list a (quote a)) 'quasiquote (let ((name 'a)) `(list ,name ',name)))
+(test '(a 3 4 5 6 b) 'quasiquote `(a ,(+ 1 2) ,@(map abs '(4 -5 6)) b))
+(test '((foo 7) . cons)
+ 'quasiquote
+ `((foo ,(- 10 3)) ,@(cdr '(c)) . ,(car '(cons))))
+
+;;; sqt is defined here because not all implementations are required to
+;;; support it.
+(define (sqt x)
+ (do ((i 0 (+ i 1)))
+ ((> (* i i) x) (- i 1))))
+
+(test '#(10 5 2 4 3 8) 'quasiquote `#(10 5 ,(sqt 4) ,@(map sqt '(16 9)) 8))
+(test 5 'quasiquote `,(+ 2 3))
+(test '(a `(b ,(+ 1 2) ,(foo 4 d) e) f)
+ 'quasiquote `(a `(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f))
+(test '(a `(b ,x ,'y d) e) 'quasiquote
+ (let ((name1 'x) (name2 'y)) `(a `(b ,,name1 ,',name2 d) e)))
+(test '(list 3 4) 'quasiquote (quasiquote (list (unquote (+ 1 2)) 4)))
+(test '`(list ,(+ 1 2) 4) 'quasiquote '(quasiquote (list (unquote (+ 1 2)) 4)))
+(SECTION 5 2 1)
+(define add3 (lambda (x) (+ x 3)))
+(test 6 'define (add3 3))
+(define first car)
+(test 1 'define (first '(1 2)))
+(SECTION 5 2 2)
+(test 45 'define
+ (let ((x 5))
+ (define foo (lambda (y) (bar x y)))
+ (define bar (lambda (a b) (+ (* a b) a)))
+ (foo (+ x 3))))
+(define x 34)
+(define (foo) (define x 5) x)
+(test 5 foo)
+(test 34 'define x)
+(define foo (lambda () (define x 5) x))
+(test 5 foo)
+(test 34 'define x)
+(define (foo x) ((lambda () (define x 5) x)) x)
+(test 88 foo 88)
+(test 4 foo 4)
+(test 34 'define x)
+(SECTION 6 1)
+(test #f not #t)
+(test #f not 3)
+(test #f not (list 3))
+(test #t not #f)
+(test #f not '())
+(test #f not (list))
+(test #f not 'nil)
+
+(test #t boolean? #f)
+(test #f boolean? 0)
+(test #f boolean? '())
+(SECTION 6 2)
+(test #t eqv? 'a 'a)
+(test #f eqv? 'a 'b)
+(test #t eqv? 2 2)
+(test #t eqv? '() '())
+(test #t eqv? '10000 '10000)
+(test #f eqv? (cons 1 2)(cons 1 2))
+(test #f eqv? (lambda () 1) (lambda () 2))
+(test #f eqv? #f 'nil)
+(let ((p (lambda (x) x)))
+ (test #t eqv? p p))
+(define gen-counter
+ (lambda ()
+ (let ((n 0))
+ (lambda () (set! n (+ n 1)) n))))
+(let ((g (gen-counter))) (test #t eqv? g g))
+(test #f eqv? (gen-counter) (gen-counter))
+(letrec ((f (lambda () (if (eqv? f g) 'f 'both)))
+ (g (lambda () (if (eqv? f g) 'g 'both))))
+ (test #f eqv? f g))
+
+(test #t eq? 'a 'a)
+(test #f eq? (list 'a) (list 'a))
+(test #t eq? '() '())
+(test #t eq? car car)
+(let ((x '(a))) (test #t eq? x x))
+(let ((x '#())) (test #t eq? x x))
+(let ((x (lambda (x) x))) (test #t eq? x x))
+
+(test #t equal? 'a 'a)
+(test #t equal? '(a) '(a))
+(test #t equal? '(a (b) c) '(a (b) c))
+(test #t equal? "abc" "abc")
+(test #t equal? 2 2)
+(test #t equal? (make-vector 5 'a) (make-vector 5 'a))
+(SECTION 6 3)
+(test '(a b c d e) 'dot '(a . (b . (c . (d . (e . ()))))))
+(define x (list 'a 'b 'c))
+(define y x)
+(and list? (test #t list? y))
+(set-cdr! x 4)
+(test '(a . 4) 'set-cdr! x)
+(test #t eqv? x y)
+(test '(a b c . d) 'dot '(a . (b . (c . d))))
+(and list? (test #f list? y))
+(and list? (let ((x (list 'a))) (set-cdr! x x) (test #f 'list? (list? x))))
+
+(test #t pair? '(a . b))
+(test #t pair? '(a . 1))
+(test #t pair? '(a b c))
+(test #f pair? '())
+(test #f pair? '#(a b))
+
+(test '(a) cons 'a '())
+(test '((a) b c d) cons '(a) '(b c d))
+(test '("a" b c) cons "a" '(b c))
+(test '(a . 3) cons 'a 3)
+(test '((a b) . c) cons '(a b) 'c)
+
+(test 'a car '(a b c))
+(test '(a) car '((a) b c d))
+(test 1 car '(1 . 2))
+
+(test '(b c d) cdr '((a) b c d))
+(test 2 cdr '(1 . 2))
+
+(test '(a 7 c) list 'a (+ 3 4) 'c)
+(test '() list)
+
+(test 3 length '(a b c))
+(test 3 length '(a (b) (c d e)))
+(test 0 length '())
+
+(test '(x y) append '(x) '(y))
+(test '(a b c d) append '(a) '(b c d))
+(test '(a (b) (c)) append '(a (b)) '((c)))
+(test '() append)
+(test '(a b c . d) append '(a b) '(c . d))
+(test 'a append '() 'a)
+
+(test '(c b a) reverse '(a b c))
+(test '((e (f)) d (b c) a) reverse '(a (b c) d (e (f))))
+
+(test 'c list-ref '(a b c d) 2)
+
+(test '(a b c) memq 'a '(a b c))
+(test '(b c) memq 'b '(a b c))
+(test '#f memq 'a '(b c d))
+(test '#f memq (list 'a) '(b (a) c))
+(test '((a) c) member (list 'a) '(b (a) c))
+(test '(101 102) memv 101 '(100 101 102))
+
+(define e '((a 1) (b 2) (c 3)))
+(test '(a 1) assq 'a e)
+(test '(b 2) assq 'b e)
+(test #f assq 'd e)
+(test #f assq (list 'a) '(((a)) ((b)) ((c))))
+(test '((a)) assoc (list 'a) '(((a)) ((b)) ((c))))
+(test '(5 7) assv 5 '((2 3) (5 7) (11 13)))
+(SECTION 6 4)
+(test #t symbol? 'foo)
+(test #t symbol? (car '(a b)))
+(test #f symbol? "bar")
+(test #t symbol? 'nil)
+(test #f symbol? '())
+(test #f symbol? #f)
+;;; But first, what case are symbols in? Determine the standard case:
+(define char-standard-case char-upcase)
+(if (string=? (symbol->string 'A) "a")
+ (set! char-standard-case char-downcase))
+(test #t 'standard-case
+ (string=? (symbol->string 'a) (symbol->string 'A)))
+(test #t 'standard-case
+ (or (string=? (symbol->string 'a) "A")
+ (string=? (symbol->string 'A) "a")))
+(define (str-copy s)
+ (let ((v (make-string (string-length s))))
+ (do ((i (- (string-length v) 1) (- i 1)))
+ ((< i 0) v)
+ (string-set! v i (string-ref s i)))))
+(define (string-standard-case s)
+ (set! s (str-copy s))
+ (do ((i 0 (+ 1 i))
+ (sl (string-length s)))
+ ((>= i sl) s)
+ (string-set! s i (char-standard-case (string-ref s i)))))
+(test (string-standard-case "flying-fish") symbol->string 'flying-fish)
+(test (string-standard-case "martin") symbol->string 'Martin)
+(test "Malvina" symbol->string (string->symbol "Malvina"))
+(test #t 'standard-case (eq? 'a 'A))
+
+(define x (string #\a #\b))
+(define y (string->symbol x))
+(string-set! x 0 #\c)
+(test "cb" 'string-set! x)
+(test "ab" symbol->string y)
+(test y string->symbol "ab")
+
+(test #t eq? 'mISSISSIppi 'mississippi)
+(test #f 'string->symbol (eq? 'bitBlt (string->symbol "bitBlt")))
+(test 'JollyWog string->symbol (symbol->string 'JollyWog))
+
+(SECTION 6 5 5)
+(test #t number? 3)
+(test #t complex? 3)
+(test #t real? 3)
+(test #t rational? 3)
+(test #t integer? 3)
+
+(test #t exact? 3)
+(test #f inexact? 3)
+
+(test #t = 22 22 22)
+(test #t = 22 22)
+(test #f = 34 34 35)
+(test #f = 34 35)
+(test #t > 3 -6246)
+(test #f > 9 9 -2424)
+(test #t >= 3 -4 -6246)
+(test #t >= 9 9)
+(test #f >= 8 9)
+(test #t < -1 2 3 4 5 6 7 8)
+(test #f < -1 2 3 4 4 5 6 7)
+(test #t <= -1 2 3 4 5 6 7 8)
+(test #t <= -1 2 3 4 4 5 6 7)
+(test #f < 1 3 2)
+(test #f >= 1 3 2)
+
+(test #t zero? 0)
+(test #f zero? 1)
+(test #f zero? -1)
+(test #f zero? -100)
+(test #t positive? 4)
+(test #f positive? -4)
+(test #f positive? 0)
+(test #f negative? 4)
+(test #t negative? -4)
+(test #f negative? 0)
+(test #t odd? 3)
+(test #f odd? 2)
+(test #f odd? -4)
+(test #t odd? -1)
+(test #f even? 3)
+(test #t even? 2)
+(test #t even? -4)
+(test #f even? -1)
+
+(test 38 max 34 5 7 38 6)
+(test -24 min 3 5 5 330 4 -24)
+
+(test 7 + 3 4)
+(test '3 + 3)
+(test 0 +)
+(test 4 * 4)
+(test 1 *)
+
+(test -1 - 3 4)
+(test -3 - 3)
+(test 7 abs -7)
+(test 7 abs 7)
+(test 0 abs 0)
+
+(test 5 quotient 35 7)
+(test -5 quotient -35 7)
+(test -5 quotient 35 -7)
+(test 5 quotient -35 -7)
+(test 1 modulo 13 4)
+(test 1 remainder 13 4)
+(test 3 modulo -13 4)
+(test -1 remainder -13 4)
+(test -3 modulo 13 -4)
+(test 1 remainder 13 -4)
+(test -1 modulo -13 -4)
+(test -1 remainder -13 -4)
+(define (divtest n1 n2)
+ (= n1 (+ (* n2 (quotient n1 n2))
+ (remainder n1 n2))))
+(test #t divtest 238 9)
+(test #t divtest -238 9)
+(test #t divtest 238 -9)
+(test #t divtest -238 -9)
+
+(test 4 gcd 0 4)
+(test 4 gcd -4 0)
+(test 4 gcd 32 -36)
+(test 0 gcd)
+(test 288 lcm 32 -36)
+(test 1 lcm)
+
+;;;;From: fred@sce.carleton.ca (Fred J Kaudel)
+;;; Modified by jaffer.
+(define (test-inexact)
+ (define f3.9 (string->number "3.9"))
+ (define f4.0 (string->number "4.0"))
+ (define f-3.25 (string->number "-3.25"))
+ (define f.25 (string->number ".25"))
+ (define f4.5 (string->number "4.5"))
+ (define f3.5 (string->number "3.5"))
+ (define f0.0 (string->number "0.0"))
+ (define f0.8 (string->number "0.8"))
+ (define f1.0 (string->number "1.0"))
+ (define wto write-test-obj)
+ (define dto display-test-obj)
+ (define lto load-test-obj)
+ (newline)
+ (display ";testing inexact numbers; ")
+ (newline)
+ (SECTION 6 5 5)
+ (test #t inexact? f3.9)
+ (test #t 'inexact? (inexact? (max f3.9 4)))
+ (test f4.0 'max (max f3.9 4))
+ (test f4.0 'exact->inexact (exact->inexact 4))
+ (test (- f4.0) round (- f4.5))
+ (test (- f4.0) round (- f3.5))
+ (test (- f4.0) round (- f3.9))
+ (test f0.0 round f0.0)
+ (test f0.0 round f.25)
+ (test f1.0 round f0.8)
+ (test f4.0 round f3.5)
+ (test f4.0 round f4.5)
+ (set! write-test-obj (list f.25 f-3.25));.25 inexact errors less likely.
+ (set! display-test-obj (list f.25 f-3.25));.3 often has such errors (~10^-13)
+ (set! load-test-obj (list 'define 'foo (list 'quote write-test-obj)))
+ (test #t call-with-output-file
+ "tmp3"
+ (lambda (test-file)
+ (write-char #\; test-file)
+ (display write-test-obj test-file)
+ (newline test-file)
+ (write load-test-obj test-file)
+ (output-port? test-file)))
+ (check-test-file "tmp3")
+ (set! write-test-obj wto)
+ (set! display-test-obj dto)
+ (set! load-test-obj lto)
+ (let ((x (string->number "4195835.0"))
+ (y (string->number "3145727.0")))
+ (test #t 'pentium-fdiv-bug (> f1.0 (- x (* (/ x y) y)))))
+ (report-errs))
+
+(define (test-bignum)
+ (define tb
+ (lambda (n1 n2)
+ (= n1 (+ (* n2 (quotient n1 n2))
+ (remainder n1 n2)))))
+ (newline)
+ (display ";testing bignums; ")
+ (newline)
+ (section 6 5 5)
+ (test 0 modulo -2177452800 86400)
+ (test 0 modulo 2177452800 -86400)
+ (test 0 modulo 2177452800 86400)
+ (test 0 modulo -2177452800 -86400)
+ (test #t 'remainder (tb 281474976710655 65535))
+ (test #t 'remainder (tb 281474976710654 65535))
+ (SECTION 6 5 6)
+ (test 281474976710655 string->number "281474976710655")
+ (test "281474976710655" number->string 281474976710655)
+ (report-errs))
+
+(SECTION 6 5 6)
+(test "0" number->string 0)
+(test "100" number->string 100)
+(test "100" number->string 256 16)
+(test 100 string->number "100")
+(test 256 string->number "100" 16)
+(test #f string->number "")
+(test #f string->number ".")
+(test #f string->number "d")
+(test #f string->number "D")
+(test #f string->number "i")
+(test #f string->number "I")
+(test #f string->number "3i")
+(test #f string->number "3I")
+(test #f string->number "33i")
+(test #f string->number "33I")
+(test #f string->number "3.3i")
+(test #f string->number "3.3I")
+(test #f string->number "-")
+(test #f string->number "+")
+
+(SECTION 6 6)
+(test #t eqv? '#\ #\Space)
+(test #t eqv? #\space '#\Space)
+(test #t char? #\a)
+(test #t char? #\()
+(test #t char? #\ )
+(test #t char? '#\newline)
+
+(test #f char=? #\A #\B)
+(test #f char=? #\a #\b)
+(test #f char=? #\9 #\0)
+(test #t char=? #\A #\A)
+
+(test #t char<? #\A #\B)
+(test #t char<? #\a #\b)
+(test #f char<? #\9 #\0)
+(test #f char<? #\A #\A)
+
+(test #f char>? #\A #\B)
+(test #f char>? #\a #\b)
+(test #t char>? #\9 #\0)
+(test #f char>? #\A #\A)
+
+(test #t char<=? #\A #\B)
+(test #t char<=? #\a #\b)
+(test #f char<=? #\9 #\0)
+(test #t char<=? #\A #\A)
+
+(test #f char>=? #\A #\B)
+(test #f char>=? #\a #\b)
+(test #t char>=? #\9 #\0)
+(test #t char>=? #\A #\A)
+
+(test #f char-ci=? #\A #\B)
+(test #f char-ci=? #\a #\B)
+(test #f char-ci=? #\A #\b)
+(test #f char-ci=? #\a #\b)
+(test #f char-ci=? #\9 #\0)
+(test #t char-ci=? #\A #\A)
+(test #t char-ci=? #\A #\a)
+
+(test #t char-ci<? #\A #\B)
+(test #t char-ci<? #\a #\B)
+(test #t char-ci<? #\A #\b)
+(test #t char-ci<? #\a #\b)
+(test #f char-ci<? #\9 #\0)
+(test #f char-ci<? #\A #\A)
+(test #f char-ci<? #\A #\a)
+
+(test #f char-ci>? #\A #\B)
+(test #f char-ci>? #\a #\B)
+(test #f char-ci>? #\A #\b)
+(test #f char-ci>? #\a #\b)
+(test #t char-ci>? #\9 #\0)
+(test #f char-ci>? #\A #\A)
+(test #f char-ci>? #\A #\a)
+
+(test #t char-ci<=? #\A #\B)
+(test #t char-ci<=? #\a #\B)
+(test #t char-ci<=? #\A #\b)
+(test #t char-ci<=? #\a #\b)
+(test #f char-ci<=? #\9 #\0)
+(test #t char-ci<=? #\A #\A)
+(test #t char-ci<=? #\A #\a)
+
+(test #f char-ci>=? #\A #\B)
+(test #f char-ci>=? #\a #\B)
+(test #f char-ci>=? #\A #\b)
+(test #f char-ci>=? #\a #\b)
+(test #t char-ci>=? #\9 #\0)
+(test #t char-ci>=? #\A #\A)
+(test #t char-ci>=? #\A #\a)
+
+(test #t char-alphabetic? #\a)
+(test #t char-alphabetic? #\A)
+(test #t char-alphabetic? #\z)
+(test #t char-alphabetic? #\Z)
+(test #f char-alphabetic? #\0)
+(test #f char-alphabetic? #\9)
+(test #f char-alphabetic? #\space)
+(test #f char-alphabetic? #\;)
+
+(test #f char-numeric? #\a)
+(test #f char-numeric? #\A)
+(test #f char-numeric? #\z)
+(test #f char-numeric? #\Z)
+(test #t char-numeric? #\0)
+(test #t char-numeric? #\9)
+(test #f char-numeric? #\space)
+(test #f char-numeric? #\;)
+
+(test #f char-whitespace? #\a)
+(test #f char-whitespace? #\A)
+(test #f char-whitespace? #\z)
+(test #f char-whitespace? #\Z)
+(test #f char-whitespace? #\0)
+(test #f char-whitespace? #\9)
+(test #t char-whitespace? #\space)
+(test #f char-whitespace? #\;)
+
+(test #f char-upper-case? #\0)
+(test #f char-upper-case? #\9)
+(test #f char-upper-case? #\space)
+(test #f char-upper-case? #\;)
+
+(test #f char-lower-case? #\0)
+(test #f char-lower-case? #\9)
+(test #f char-lower-case? #\space)
+(test #f char-lower-case? #\;)
+
+(test #\. integer->char (char->integer #\.))
+(test #\A integer->char (char->integer #\A))
+(test #\a integer->char (char->integer #\a))
+(test #\A char-upcase #\A)
+(test #\A char-upcase #\a)
+(test #\a char-downcase #\A)
+(test #\a char-downcase #\a)
+(SECTION 6 7)
+(test #t string? "The word \"recursion\\\" has many meanings.")
+(test #t string? "")
+(define f (make-string 3 #\*))
+(test "?**" 'string-set! (begin (string-set! f 0 #\?) f))
+(test "abc" string #\a #\b #\c)
+(test "" string)
+(test 3 string-length "abc")
+(test #\a string-ref "abc" 0)
+(test #\c string-ref "abc" 2)
+(test 0 string-length "")
+(test "" substring "ab" 0 0)
+(test "" substring "ab" 1 1)
+(test "" substring "ab" 2 2)
+(test "a" substring "ab" 0 1)
+(test "b" substring "ab" 1 2)
+(test "ab" substring "ab" 0 2)
+(test "foobar" string-append "foo" "bar")
+(test "foo" string-append "foo")
+(test "foo" string-append "foo" "")
+(test "foo" string-append "" "foo")
+(test "" string-append)
+(test "" make-string 0)
+(test #t string=? "" "")
+(test #f string<? "" "")
+(test #f string>? "" "")
+(test #t string<=? "" "")
+(test #t string>=? "" "")
+(test #t string-ci=? "" "")
+(test #f string-ci<? "" "")
+(test #f string-ci>? "" "")
+(test #t string-ci<=? "" "")
+(test #t string-ci>=? "" "")
+
+(test #f string=? "A" "B")
+(test #f string=? "a" "b")
+(test #f string=? "9" "0")
+(test #t string=? "A" "A")
+
+(test #t string<? "A" "B")
+(test #t string<? "a" "b")
+(test #f string<? "9" "0")
+(test #f string<? "A" "A")
+
+(test #f string>? "A" "B")
+(test #f string>? "a" "b")
+(test #t string>? "9" "0")
+(test #f string>? "A" "A")
+
+(test #t string<=? "A" "B")
+(test #t string<=? "a" "b")
+(test #f string<=? "9" "0")
+(test #t string<=? "A" "A")
+
+(test #f string>=? "A" "B")
+(test #f string>=? "a" "b")
+(test #t string>=? "9" "0")
+(test #t string>=? "A" "A")
+
+(test #f string-ci=? "A" "B")
+(test #f string-ci=? "a" "B")
+(test #f string-ci=? "A" "b")
+(test #f string-ci=? "a" "b")
+(test #f string-ci=? "9" "0")
+(test #t string-ci=? "A" "A")
+(test #t string-ci=? "A" "a")
+
+(test #t string-ci<? "A" "B")
+(test #t string-ci<? "a" "B")
+(test #t string-ci<? "A" "b")
+(test #t string-ci<? "a" "b")
+(test #f string-ci<? "9" "0")
+(test #f string-ci<? "A" "A")
+(test #f string-ci<? "A" "a")
+
+(test #f string-ci>? "A" "B")
+(test #f string-ci>? "a" "B")
+(test #f string-ci>? "A" "b")
+(test #f string-ci>? "a" "b")
+(test #t string-ci>? "9" "0")
+(test #f string-ci>? "A" "A")
+(test #f string-ci>? "A" "a")
+
+(test #t string-ci<=? "A" "B")
+(test #t string-ci<=? "a" "B")
+(test #t string-ci<=? "A" "b")
+(test #t string-ci<=? "a" "b")
+(test #f string-ci<=? "9" "0")
+(test #t string-ci<=? "A" "A")
+(test #t string-ci<=? "A" "a")
+
+(test #f string-ci>=? "A" "B")
+(test #f string-ci>=? "a" "B")
+(test #f string-ci>=? "A" "b")
+(test #f string-ci>=? "a" "b")
+(test #t string-ci>=? "9" "0")
+(test #t string-ci>=? "A" "A")
+(test #t string-ci>=? "A" "a")
+(SECTION 6 8)
+(test #t vector? '#(0 (2 2 2 2) "Anna"))
+(test #t vector? '#())
+(test '#(a b c) vector 'a 'b 'c)
+(test '#() vector)
+(test 3 vector-length '#(0 (2 2 2 2) "Anna"))
+(test 0 vector-length '#())
+(test 8 vector-ref '#(1 1 2 3 5 8 13 21) 5)
+(test '#(0 ("Sue" "Sue") "Anna") 'vector-set
+ (let ((vec (vector 0 '(2 2 2 2) "Anna")))
+ (vector-set! vec 1 '("Sue" "Sue"))
+ vec))
+(test '#(hi hi) make-vector 2 'hi)
+(test '#() make-vector 0)
+(test '#() make-vector 0 'a)
+(SECTION 6 9)
+(test #t procedure? car)
+(test #f procedure? 'car)
+(test #t procedure? (lambda (x) (* x x)))
+(test #f procedure? '(lambda (x) (* x x)))
+(test #t call-with-current-continuation procedure?)
+(test 7 apply + (list 3 4))
+(test 7 apply (lambda (a b) (+ a b)) (list 3 4))
+(test 17 apply + 10 (list 3 4))
+(test '() apply list '())
+(define compose (lambda (f g) (lambda args (f (apply g args)))))
+(test 30 (compose sqt *) 12 75)
+
+(test '(b e h) map cadr '((a b) (d e) (g h)))
+(test '(5 7 9) map + '(1 2 3) '(4 5 6))
+(test '#(0 1 4 9 16) 'for-each
+ (let ((v (make-vector 5)))
+ (for-each (lambda (i) (vector-set! v i (* i i)))
+ '(0 1 2 3 4))
+ v))
+(test -3 call-with-current-continuation
+ (lambda (exit)
+ (for-each (lambda (x) (if (negative? x) (exit x)))
+ '(54 0 37 -3 245 19))
+ #t))
+(define list-length
+ (lambda (obj)
+ (call-with-current-continuation
+ (lambda (return)
+ (letrec ((r (lambda (obj) (cond ((null? obj) 0)
+ ((pair? obj) (+ (r (cdr obj)) 1))
+ (else (return #f))))))
+ (r obj))))))
+(test 4 list-length '(1 2 3 4))
+(test #f list-length '(a b . c))
+(test '() map cadr '())
+
+;;; This tests full conformance of call-with-current-continuation. It
+;;; is a separate test because some schemes do not support call/cc
+;;; other than escape procedures. I am indebted to
+;;; raja@copper.ucs.indiana.edu (Raja Sooriamurthi) for fixing this
+;;; code. The function leaf-eq? compares the leaves of 2 arbitrary
+;;; trees constructed of conses.
+(define (next-leaf-generator obj eot)
+ (letrec ((return #f)
+ (cont (lambda (x)
+ (recur obj)
+ (set! cont (lambda (x) (return eot)))
+ (cont #f)))
+ (recur (lambda (obj)
+ (if (pair? obj)
+ (for-each recur obj)
+ (call-with-current-continuation
+ (lambda (c)
+ (set! cont c)
+ (return obj)))))))
+ (lambda () (call-with-current-continuation
+ (lambda (ret) (set! return ret) (cont #f))))))
+(define (leaf-eq? x y)
+ (let* ((eot (list 'eot))
+ (xf (next-leaf-generator x eot))
+ (yf (next-leaf-generator y eot)))
+ (letrec ((loop (lambda (x y)
+ (cond ((not (eq? x y)) #f)
+ ((eq? eot x) #t)
+ (else (loop (xf) (yf)))))))
+ (loop (xf) (yf)))))
+(define (test-cont)
+ (newline)
+ (display ";testing continuations; ")
+ (newline)
+ (SECTION 6 9)
+ (test #t leaf-eq? '(a (b (c))) '((a) b c))
+ (test #f leaf-eq? '(a (b (c))) '((a) b c d))
+ (report-errs))
+
+;;; Test Optional R4RS DELAY syntax and FORCE procedure
+(define (test-delay)
+ (newline)
+ (display ";testing DELAY and FORCE; ")
+ (newline)
+ (SECTION 6 9)
+ (test 3 'delay (force (delay (+ 1 2))))
+ (test '(3 3) 'delay (let ((p (delay (+ 1 2))))
+ (list (force p) (force p))))
+ (test 2 'delay (letrec ((a-stream
+ (letrec ((next (lambda (n)
+ (cons n (delay (next (+ n 1)))))))
+ (next 0)))
+ (head car)
+ (tail (lambda (stream) (force (cdr stream)))))
+ (head (tail (tail a-stream)))))
+ (letrec ((count 0)
+ (p (delay (begin (set! count (+ count 1))
+ (if (> count x)
+ count
+ (force p)))))
+ (x 5))
+ (test 6 force p)
+ (set! x 10)
+ (test 6 force p))
+ (test 3 'force
+ (letrec ((p (delay (if c 3 (begin (set! c #t) (+ (force p) 1)))))
+ (c #f))
+ (force p)))
+ (report-errs))
+
+(SECTION 6 10 1)
+(test #t input-port? (current-input-port))
+(test #t output-port? (current-output-port))
+(test #t call-with-input-file "test.scm" input-port?)
+(define this-file (open-input-file "test.scm"))
+(test #t input-port? this-file)
+(SECTION 6 10 2)
+(test #\; peek-char this-file)
+(test #\; read-char this-file)
+(test '(define cur-section '()) read this-file)
+(test #\( peek-char this-file)
+(test '(define errs '()) read this-file)
+(close-input-port this-file)
+(close-input-port this-file)
+(define (check-test-file name)
+ (define test-file (open-input-file name))
+ (test #t 'input-port?
+ (call-with-input-file
+ name
+ (lambda (test-file)
+ (test load-test-obj read test-file)
+ (test #t eof-object? (peek-char test-file))
+ (test #t eof-object? (read-char test-file))
+ (input-port? test-file))))
+ (test #\; read-char test-file)
+ (test display-test-obj read test-file)
+ (test load-test-obj read test-file)
+ (close-input-port test-file))
+(SECTION 6 10 3)
+(define write-test-obj
+ '(#t #f #\a () 9739 -3 . #((test) "te \" \" st" "" test #() b c)))
+(define display-test-obj
+ '(#t #f a () 9739 -3 . #((test) te " " st test #() b c)))
+(define load-test-obj
+ (list 'define 'foo (list 'quote write-test-obj)))
+(test #t call-with-output-file
+ "tmp1"
+ (lambda (test-file)
+ (write-char #\; test-file)
+ (display write-test-obj test-file)
+ (newline test-file)
+ (write load-test-obj test-file)
+ (output-port? test-file)))
+(check-test-file "tmp1")
+
+(define test-file (open-output-file "tmp2"))
+(write-char #\; test-file)
+(display write-test-obj test-file)
+(newline test-file)
+(write load-test-obj test-file)
+(test #t output-port? test-file)
+(close-output-port test-file)
+(check-test-file "tmp2")
+(define (test-sc4)
+ (newline)
+ (display ";testing scheme 4 functions; ")
+ (newline)
+ (SECTION 6 7)
+ (test '(#\P #\space #\l) string->list "P l")
+ (test '() string->list "")
+ (test "1\\\"" list->string '(#\1 #\\ #\"))
+ (test "" list->string '())
+ (SECTION 6 8)
+ (test '(dah dah didah) vector->list '#(dah dah didah))
+ (test '() vector->list '#())
+ (test '#(dididit dah) list->vector '(dididit dah))
+ (test '#() list->vector '())
+ (SECTION 6 10 4)
+ (load "tmp1")
+ (test write-test-obj 'load foo)
+ (report-errs))
+
+(report-errs)
+(if (and (string->number "0.0") (inexact? (string->number "0.0")))
+ (test-inexact))
+
+(let ((n (string->number "281474976710655")))
+ (if (and n (exact? n))
+ (test-bignum)))
+(newline)
+(display "To fully test continuations, Scheme 4, and DELAY/FORCE do:")
+(newline)
+(display "(test-cont) (test-sc4) (test-delay)")
+(newline)
+"last item in file"
diff --git a/ipl/packs/skeem/test.std b/ipl/packs/skeem/test.std
new file mode 100644
index 0000000..543ff04
--- /dev/null
+++ b/ipl/packs/skeem/test.std
@@ -0,0 +1,1180 @@
+CUR-SECTION
+ERRS
+SECTION
+RECORD-ERROR
+TEST
+REPORT-ERRS
+SECTION(2 1)
+#t
+(+ - ... !.. $.+ %.- &.! *.: /:. :+. <-. =. >. ?. ~. _. ^.)
+SECTION(3 4)
+#t
+DISJOINT-TYPE-FUNCTIONS
+TYPE-EXAMPLES
+I
+ #<procedure BOOLEAN_P>
+ #<procedure CHAR_P>
+ #<procedure NULL_P>
+ #<procedure NUMBER_P>
+ #<procedure PAIR_P>
+ #<procedure PROCEDURE_P>
+ #<procedure STRING_P>
+ #<procedure SYMBOL_P>
+ #<procedure VECTOR_P>
+#<output &output>
+(#t #f #f #f #f #f #f #f #f)#t
+(#t #f #f #f #f #f #f #f #f)#f
+(#f #t #f #f #f #f #f #f #f)#\a
+(#f #f #t #f #f #f #f #f #f)()
+(#f #f #f #t #f #f #f #f #f)9739
+(#f #f #f #f #t #f #f #f #f)(TEST)
+(#f #f #f #f #f #t #f #f #f)#<interpreted function RECORD-ERROR>
+(#f #f #f #f #f #f #t #f #f)"test"
+(#f #f #f #f #f #f #t #f #f)""
+(#f #f #f #f #f #f #f #t #f)TEST
+(#f #f #f #f #f #f #f #f #t)#()
+(#f #f #f #f #f #f #f #f #t)#(A B C)
+TYPE-MATRIX
+SECTION(4 1 2)
+#t
+(QUOTE (QUOTE A)) ==> (QUOTE A)
+#t
+(QUOTE (QUOTE A)) ==> (QUOTE A)
+#t
+SECTION(4 1 3)
+#t
+(#<procedure MULTIPLY> 3 4) ==> 12
+#t
+SECTION(4 1 4)
+#t
+(#<interpreted function ???> 4) ==> 8
+#t
+REVERSE-SUBTRACT
+(#<interpreted function REVERSE-SUBTRACT> 7 10) ==> 3
+#t
+ADD4
+(#<interpreted function ADD4> 6) ==> 10
+#t
+(#<interpreted function ???> 3 4 5 6) ==> (3 4 5 6)
+#t
+(#<interpreted function ???> 3 4 5 6) ==> (5 6)
+#t
+SECTION(4 1 5)
+#t
+(IF YES) ==> YES
+#t
+(IF NO) ==> NO
+#t
+(IF 1) ==> 1
+#t
+SECTION(4 1 6)
+#t
+X
+(DEFINE 3) ==> 3
+#t
+4
+(SET! 5) ==> 5
+#t
+SECTION(4 2 1)
+#t
+(COND GREATER) ==> GREATER
+#t
+(COND EQUAL) ==> EQUAL
+#t
+(COND 2) ==> 2
+#t
+(CASE COMPOSITE) ==> COMPOSITE
+#t
+(CASE CONSONANT) ==> CONSONANT
+#t
+(AND #t) ==> #t
+#t
+(AND #f) ==> #f
+#t
+(AND (F G)) ==> (F G)
+#t
+(AND #t) ==> #t
+#t
+(OR #t) ==> #t
+#t
+(OR #t) ==> #t
+#t
+(OR #f) ==> #f
+#t
+(OR #f) ==> #f
+#t
+(OR (B C)) ==> (B C)
+#t
+SECTION(4 2 2)
+#t
+(LET 6) ==> 6
+#t
+(LET 35) ==> 35
+#t
+(LET* 70) ==> 70
+#t
+(LETREC #t) ==> #t
+#t
+X
+(LET 5) ==> 5
+#t
+(LET 34) ==> 34
+#t
+(LET 6) ==> 6
+#t
+(LET 34) ==> 34
+#t
+(LET* 7) ==> 7
+#t
+(LET* 34) ==> 34
+#t
+(LET* 8) ==> 8
+#t
+(LET* 34) ==> 34
+#t
+(LETREC 9) ==> 9
+#t
+(LETREC 34) ==> 34
+#t
+(LETREC 10) ==> 10
+#t
+(LETREC 34) ==> 34
+#t
+SECTION(4 2 3)
+#t
+X
+(BEGIN 6) ==> 6
+#t
+SECTION(4 2 4)
+#t
+(DO #(0 1 2 3 4)) ==> #(0 1 2 3 4)
+#t
+(DO 25) ==> 25
+#t
+(LET 1) ==> 1
+#t
+(LET ((6 1 3) (-5 -2))) ==> ((6 1 3) (-5 -2))
+#t
+SECTION(4 2 6)
+#t
+(QUASIQUOTE (LIST 3 4)) ==> (LIST 3 4)
+#t
+(QUASIQUOTE (LIST A (QUOTE A))) ==> (LIST A (QUOTE A))
+#t
+(QUASIQUOTE (A 3 4 5 6 B)) ==> (A 3 4 5 6 B)
+#t
+(QUASIQUOTE ((FOO 7) . CONS)) ==> ((FOO 7) . CONS)
+#t
+SQT
+(QUASIQUOTE #(10 5 2 4 3 8)) ==> #(10 5 2 4 3 8)
+#t
+(QUASIQUOTE 5) ==> 5
+#t
+(QUASIQUOTE (A (QUASIQUOTE (B (UNQUOTE (+ 1 2)) (UNQUOTE (FOO 4 D)) E)) F)) ==> (A (QUASIQUOTE (B (UNQUOTE (+ 1 2)) (UNQUOTE (FOO 4 D)) E)) F)
+#t
+(QUASIQUOTE (A (QUASIQUOTE (B (UNQUOTE X) (UNQUOTE (QUOTE Y)) D)) E)) ==> (A (QUASIQUOTE (B (UNQUOTE X) (UNQUOTE (QUOTE Y)) D)) E)
+#t
+(QUASIQUOTE (LIST 3 4)) ==> (LIST 3 4)
+#t
+(QUASIQUOTE (QUASIQUOTE (LIST (UNQUOTE (+ 1 2)) 4))) ==> (QUASIQUOTE (LIST (UNQUOTE (+ 1 2)) 4))
+#t
+SECTION(5 2 1)
+#t
+ADD3
+(DEFINE 6) ==> 6
+#t
+FIRST
+(DEFINE 1) ==> 1
+#t
+SECTION(5 2 2)
+#t
+(DEFINE 45) ==> 45
+#t
+X
+FOO
+(#<interpreted function FOO>) ==> 5
+#t
+(DEFINE 34) ==> 34
+#t
+FOO
+(#<interpreted function FOO>) ==> 5
+#t
+(DEFINE 34) ==> 34
+#t
+FOO
+(#<interpreted function FOO> 88) ==> 88
+#t
+(#<interpreted function FOO> 4) ==> 4
+#t
+(DEFINE 34) ==> 34
+#t
+SECTION(6 1)
+#t
+(#<procedure NOT> #t) ==> #f
+#t
+(#<procedure NOT> 3) ==> #f
+#t
+(#<procedure NOT> (3)) ==> #f
+#t
+(#<procedure NOT> #f) ==> #t
+#t
+(#<procedure NOT> ()) ==> #f
+#t
+(#<procedure NOT> ()) ==> #f
+#t
+(#<procedure NOT> NIL) ==> #f
+#t
+(#<procedure BOOLEAN_P> #f) ==> #t
+#t
+(#<procedure BOOLEAN_P> 0) ==> #f
+#t
+(#<procedure BOOLEAN_P> ()) ==> #f
+#t
+SECTION(6 2)
+#t
+(#<procedure EQV_P> A A) ==> #t
+#t
+(#<procedure EQV_P> A B) ==> #f
+#t
+(#<procedure EQV_P> 2 2) ==> #t
+#t
+(#<procedure EQV_P> () ()) ==> #t
+#t
+(#<procedure EQV_P> 10000 10000) ==> #t
+#t
+(#<procedure EQV_P> (1 . 2) (1 . 2)) ==> #f
+#t
+(#<procedure EQV_P> #<interpreted function ???> #<interpreted function ???>) ==> #f
+#t
+(#<procedure EQV_P> #f NIL) ==> #f
+#t
+(#<procedure EQV_P> #<interpreted function ???> #<interpreted function ???>) ==> #t
+#t
+GEN-COUNTER
+(#<procedure EQV_P> #<interpreted function ???> #<interpreted function ???>) ==> #t
+#t
+(#<procedure EQV_P> #<interpreted function ???> #<interpreted function ???>) ==> #f
+#t
+(#<procedure EQV_P> #<interpreted function ???> #<interpreted function ???>) ==> #f
+#t
+(#<procedure EQ_P> A A) ==> #t
+#t
+(#<procedure EQ_P> (A) (A)) ==> #f
+#t
+(#<procedure EQ_P> () ()) ==> #t
+#t
+(#<procedure EQ_P> #<procedure CAR> #<procedure CAR>) ==> #t
+#t
+(#<procedure EQ_P> (A) (A)) ==> #t
+#t
+(#<procedure EQ_P> #() #()) ==> #t
+#t
+(#<procedure EQ_P> #<interpreted function ???> #<interpreted function ???>) ==> #t
+#t
+(#<procedure EQUAL_P> A A) ==> #t
+#t
+(#<procedure EQUAL_P> (A) (A)) ==> #t
+#t
+(#<procedure EQUAL_P> (A (B) C) (A (B) C)) ==> #t
+#t
+(#<procedure EQUAL_P> "abc" "abc") ==> #t
+#t
+(#<procedure EQUAL_P> 2 2) ==> #t
+#t
+(#<procedure EQUAL_P> #(A A A A A) #(A A A A A)) ==> #t
+#t
+SECTION(6 3)
+#t
+(DOT (A B C D E)) ==> (A B C D E)
+#t
+X
+Y
+(#<procedure LIST_P> (A B C)) ==> #t
+#t
+4
+(SET-CDR! (A . 4)) ==> (A . 4)
+#t
+(#<procedure EQV_P> (A . 4) (A . 4)) ==> #t
+#t
+(DOT (A B C . D)) ==> (A B C . D)
+#t
+(#<procedure LIST_P> (A . 4)) ==> #f
+#t
+(LIST? #f) ==> #f
+#t
+(#<procedure PAIR_P> (A . B)) ==> #t
+#t
+(#<procedure PAIR_P> (A . 1)) ==> #t
+#t
+(#<procedure PAIR_P> (A B C)) ==> #t
+#t
+(#<procedure PAIR_P> ()) ==> #f
+#t
+(#<procedure PAIR_P> #(A B)) ==> #f
+#t
+(#<procedure CONS> A ()) ==> (A)
+#t
+(#<procedure CONS> (A) (B C D)) ==> ((A) B C D)
+#t
+(#<procedure CONS> "a" (B C)) ==> ("a" B C)
+#t
+(#<procedure CONS> A 3) ==> (A . 3)
+#t
+(#<procedure CONS> (A B) C) ==> ((A B) . C)
+#t
+(#<procedure CAR> (A B C)) ==> A
+#t
+(#<procedure CAR> ((A) B C D)) ==> (A)
+#t
+(#<procedure CAR> (1 . 2)) ==> 1
+#t
+(#<procedure CDR> ((A) B C D)) ==> (B C D)
+#t
+(#<procedure CDR> (1 . 2)) ==> 2
+#t
+(#<procedure LIST> A 7 C) ==> (A 7 C)
+#t
+(#<procedure LIST>) ==> ()
+#t
+(#<procedure LENGTH> (A B C)) ==> 3
+#t
+(#<procedure LENGTH> (A (B) (C D E))) ==> 3
+#t
+(#<procedure LENGTH> ()) ==> 0
+#t
+(#<procedure APPEND> (X) (Y)) ==> (X Y)
+#t
+(#<procedure APPEND> (A) (B C D)) ==> (A B C D)
+#t
+(#<procedure APPEND> (A (B)) ((C))) ==> (A (B) (C))
+#t
+(#<procedure APPEND>) ==> ()
+#t
+(#<procedure APPEND> (A B) (C . D)) ==> (A B C . D)
+#t
+(#<procedure APPEND> () A) ==> A
+#t
+(#<procedure REVERSE> (A B C)) ==> (C B A)
+#t
+(#<procedure REVERSE> (A (B C) D (E (F)))) ==> ((E (F)) D (B C) A)
+#t
+(#<procedure LIST_REF> (A B C D) 2) ==> C
+#t
+(#<procedure MEMQ> A (A B C)) ==> (A B C)
+#t
+(#<procedure MEMQ> B (A B C)) ==> (B C)
+#t
+(#<procedure MEMQ> A (B C D)) ==> #f
+#t
+(#<procedure MEMQ> (A) (B (A) C)) ==> #f
+#t
+(#<procedure MEMBER> (A) (B (A) C)) ==> ((A) C)
+#t
+(#<procedure MEMV> 101 (100 101 102)) ==> (101 102)
+#t
+E
+(#<procedure ASSQ> A ((A 1) (B 2) (C 3))) ==> (A 1)
+#t
+(#<procedure ASSQ> B ((A 1) (B 2) (C 3))) ==> (B 2)
+#t
+(#<procedure ASSQ> D ((A 1) (B 2) (C 3))) ==> #f
+#t
+(#<procedure ASSQ> (A) (((A)) ((B)) ((C)))) ==> #f
+#t
+(#<procedure ASSOC> (A) (((A)) ((B)) ((C)))) ==> ((A))
+#t
+(#<procedure ASSV> 5 ((2 3) (5 7) (11 13))) ==> (5 7)
+#t
+SECTION(6 4)
+#t
+(#<procedure SYMBOL_P> FOO) ==> #t
+#t
+(#<procedure SYMBOL_P> A) ==> #t
+#t
+(#<procedure SYMBOL_P> "bar") ==> #f
+#t
+(#<procedure SYMBOL_P> NIL) ==> #t
+#t
+(#<procedure SYMBOL_P> ()) ==> #f
+#t
+(#<procedure SYMBOL_P> #f) ==> #f
+#t
+CHAR-STANDARD-CASE
+#f
+(STANDARD-CASE #t) ==> #t
+#t
+(STANDARD-CASE #t) ==> #t
+#t
+STR-COPY
+STRING-STANDARD-CASE
+(#<procedure SYMBOL_2_STRING> FLYING-FISH) ==> "FLYING-FISH"
+#t
+(#<procedure SYMBOL_2_STRING> MARTIN) ==> "MARTIN"
+#t
+(#<procedure SYMBOL_2_STRING> |Malvina|) ==> "Malvina"
+#t
+(STANDARD-CASE #t) ==> #t
+#t
+X
+Y
+"cb"
+(STRING-SET! "cb") ==> "cb"
+#t
+(#<procedure SYMBOL_2_STRING> |ab|) ==> "ab"
+#t
+(#<procedure STRING_2_SYMBOL> "ab") ==> |ab|
+#t
+(#<procedure EQ_P> MISSISSIPPI MISSISSIPPI) ==> #t
+#t
+(STRING->SYMBOL #f) ==> #f
+#t
+(#<procedure STRING_2_SYMBOL> "JOLLYWOG") ==> JOLLYWOG
+#t
+SECTION(6 5 5)
+#t
+(#<procedure NUMBER_P> 3) ==> #t
+#t
+(#<procedure COMPLEX_P> 3) ==> #t
+#t
+(#<procedure REAL_P> 3) ==> #t
+#t
+(#<procedure RATIONAL_P> 3) ==> #t
+#t
+(#<procedure INTEGER_P> 3) ==> #t
+#t
+(#<procedure EXACT_P> 3) ==> #t
+#t
+(#<procedure INEXACT_P> 3) ==> #f
+#t
+(#<procedure EQ> 22 22 22) ==> #t
+#t
+(#<procedure EQ> 22 22) ==> #t
+#t
+(#<procedure EQ> 34 34 35) ==> #f
+#t
+(#<procedure EQ> 34 35) ==> #f
+#t
+(#<procedure GT> 3 -6246) ==> #t
+#t
+(#<procedure GT> 9 9 -2424) ==> #f
+#t
+(#<procedure GE> 3 -4 -6246) ==> #t
+#t
+(#<procedure GE> 9 9) ==> #t
+#t
+(#<procedure GE> 8 9) ==> #f
+#t
+(#<procedure LT> -1 2 3 4 5 6 7 8) ==> #t
+#t
+(#<procedure LT> -1 2 3 4 4 5 6 7) ==> #f
+#t
+(#<procedure LE> -1 2 3 4 5 6 7 8) ==> #t
+#t
+(#<procedure LE> -1 2 3 4 4 5 6 7) ==> #t
+#t
+(#<procedure LT> 1 3 2) ==> #f
+#t
+(#<procedure GE> 1 3 2) ==> #f
+#t
+(#<procedure ZERO_P> 0) ==> #t
+#t
+(#<procedure ZERO_P> 1) ==> #f
+#t
+(#<procedure ZERO_P> -1) ==> #f
+#t
+(#<procedure ZERO_P> -100) ==> #f
+#t
+(#<procedure POSITIVE_P> 4) ==> #t
+#t
+(#<procedure POSITIVE_P> -4) ==> #f
+#t
+(#<procedure POSITIVE_P> 0) ==> #f
+#t
+(#<procedure NEGATIVE_P> 4) ==> #f
+#t
+(#<procedure NEGATIVE_P> -4) ==> #t
+#t
+(#<procedure NEGATIVE_P> 0) ==> #f
+#t
+(#<procedure ODD_P> 3) ==> #t
+#t
+(#<procedure ODD_P> 2) ==> #f
+#t
+(#<procedure ODD_P> -4) ==> #f
+#t
+(#<procedure ODD_P> -1) ==> #t
+#t
+(#<procedure EVEN_P> 3) ==> #f
+#t
+(#<procedure EVEN_P> 2) ==> #t
+#t
+(#<procedure EVEN_P> -4) ==> #t
+#t
+(#<procedure EVEN_P> -1) ==> #f
+#t
+(#<procedure MAX> 34 5 7 38 6) ==> 38
+#t
+(#<procedure MIN> 3 5 5 330 4 -24) ==> -24
+#t
+(#<procedure ADD> 3 4) ==> 7
+#t
+(#<procedure ADD> 3) ==> 3
+#t
+(#<procedure ADD>) ==> 0
+#t
+(#<procedure MULTIPLY> 4) ==> 4
+#t
+(#<procedure MULTIPLY>) ==> 1
+#t
+(#<procedure SUBTRACT> 3 4) ==> -1
+#t
+(#<procedure SUBTRACT> 3) ==> -3
+#t
+(#<procedure ABS> -7) ==> 7
+#t
+(#<procedure ABS> 7) ==> 7
+#t
+(#<procedure ABS> 0) ==> 0
+#t
+(#<procedure QUOTIENT> 35 7) ==> 5
+#t
+(#<procedure QUOTIENT> -35 7) ==> -5
+#t
+(#<procedure QUOTIENT> 35 -7) ==> -5
+#t
+(#<procedure QUOTIENT> -35 -7) ==> 5
+#t
+(#<procedure MODULO> 13 4) ==> 1
+#t
+(#<procedure REMAINDER> 13 4) ==> 1
+#t
+(#<procedure MODULO> -13 4) ==> 3
+#t
+(#<procedure REMAINDER> -13 4) ==> -1
+#t
+(#<procedure MODULO> 13 -4) ==> -3
+#t
+(#<procedure REMAINDER> 13 -4) ==> 1
+#t
+(#<procedure MODULO> -13 -4) ==> -1
+#t
+(#<procedure REMAINDER> -13 -4) ==> -1
+#t
+DIVTEST
+(#<interpreted function DIVTEST> 238 9) ==> #t
+#t
+(#<interpreted function DIVTEST> -238 9) ==> #t
+#t
+(#<interpreted function DIVTEST> 238 -9) ==> #t
+#t
+(#<interpreted function DIVTEST> -238 -9) ==> #t
+#t
+(#<procedure GCD> 0 4) ==> 4
+#t
+(#<procedure GCD> -4 0) ==> 4
+#t
+(#<procedure GCD> 32 -36) ==> 4
+#t
+(#<procedure GCD>) ==> 0
+#t
+(#<procedure LCM> 32 -36) ==> 288
+#t
+(#<procedure LCM>) ==> 1
+#t
+TEST-INEXACT
+TEST-BIGNUM
+SECTION(6 5 6)
+#t
+(#<procedure NUMBER_2_STRING> 0) ==> "0"
+#t
+(#<procedure NUMBER_2_STRING> 100) ==> "100"
+#t
+(#<procedure NUMBER_2_STRING> 256 16) ==> "100"
+#t
+(#<procedure STRING_2_NUMBER> "100") ==> 100
+#t
+(#<procedure STRING_2_NUMBER> "100" 16) ==> 256
+#t
+(#<procedure STRING_2_NUMBER> "") ==> #f
+#t
+(#<procedure STRING_2_NUMBER> ".") ==> #f
+#t
+(#<procedure STRING_2_NUMBER> "d") ==> #f
+#t
+(#<procedure STRING_2_NUMBER> "D") ==> #f
+#t
+(#<procedure STRING_2_NUMBER> "i") ==> #f
+#t
+(#<procedure STRING_2_NUMBER> "I") ==> #f
+#t
+(#<procedure STRING_2_NUMBER> "3i") ==> #f
+#t
+(#<procedure STRING_2_NUMBER> "3I") ==> #f
+#t
+(#<procedure STRING_2_NUMBER> "33i") ==> #f
+#t
+(#<procedure STRING_2_NUMBER> "33I") ==> #f
+#t
+(#<procedure STRING_2_NUMBER> "3.3i") ==> #f
+#t
+(#<procedure STRING_2_NUMBER> "3.3I") ==> #f
+#t
+(#<procedure STRING_2_NUMBER> "-") ==> #f
+#t
+(#<procedure STRING_2_NUMBER> "+") ==> #f
+#t
+SECTION(6 6)
+#t
+(#<procedure EQV_P> #\space #\space) ==> #t
+#t
+(#<procedure EQV_P> #\space #\space) ==> #t
+#t
+(#<procedure CHAR_P> #\a) ==> #t
+#t
+(#<procedure CHAR_P> #\() ==> #t
+#t
+(#<procedure CHAR_P> #\space) ==> #t
+#t
+(#<procedure CHAR_P> #\newline) ==> #t
+#t
+(#<procedure CHAR_EQ> #\A #\B) ==> #f
+#t
+(#<procedure CHAR_EQ> #\a #\b) ==> #f
+#t
+(#<procedure CHAR_EQ> #\9 #\0) ==> #f
+#t
+(#<procedure CHAR_EQ> #\A #\A) ==> #t
+#t
+(#<procedure CHAR_LT> #\A #\B) ==> #t
+#t
+(#<procedure CHAR_LT> #\a #\b) ==> #t
+#t
+(#<procedure CHAR_LT> #\9 #\0) ==> #f
+#t
+(#<procedure CHAR_LT> #\A #\A) ==> #f
+#t
+(#<procedure CHAR_GT> #\A #\B) ==> #f
+#t
+(#<procedure CHAR_GT> #\a #\b) ==> #f
+#t
+(#<procedure CHAR_GT> #\9 #\0) ==> #t
+#t
+(#<procedure CHAR_GT> #\A #\A) ==> #f
+#t
+(#<procedure CHAR_LE> #\A #\B) ==> #t
+#t
+(#<procedure CHAR_LE> #\a #\b) ==> #t
+#t
+(#<procedure CHAR_LE> #\9 #\0) ==> #f
+#t
+(#<procedure CHAR_LE> #\A #\A) ==> #t
+#t
+(#<procedure CHAR_GE> #\A #\B) ==> #f
+#t
+(#<procedure CHAR_GE> #\a #\b) ==> #f
+#t
+(#<procedure CHAR_GE> #\9 #\0) ==> #t
+#t
+(#<procedure CHAR_GE> #\A #\A) ==> #t
+#t
+(#<procedure CHAR_CI_EQ> #\A #\B) ==> #f
+#t
+(#<procedure CHAR_CI_EQ> #\a #\B) ==> #f
+#t
+(#<procedure CHAR_CI_EQ> #\A #\b) ==> #f
+#t
+(#<procedure CHAR_CI_EQ> #\a #\b) ==> #f
+#t
+(#<procedure CHAR_CI_EQ> #\9 #\0) ==> #f
+#t
+(#<procedure CHAR_CI_EQ> #\A #\A) ==> #t
+#t
+(#<procedure CHAR_CI_EQ> #\A #\a) ==> #t
+#t
+(#<procedure CHAR_CI_LT> #\A #\B) ==> #t
+#t
+(#<procedure CHAR_CI_LT> #\a #\B) ==> #t
+#t
+(#<procedure CHAR_CI_LT> #\A #\b) ==> #t
+#t
+(#<procedure CHAR_CI_LT> #\a #\b) ==> #t
+#t
+(#<procedure CHAR_CI_LT> #\9 #\0) ==> #f
+#t
+(#<procedure CHAR_CI_LT> #\A #\A) ==> #f
+#t
+(#<procedure CHAR_CI_LT> #\A #\a) ==> #f
+#t
+(#<procedure CHAR_CI_GT> #\A #\B) ==> #f
+#t
+(#<procedure CHAR_CI_GT> #\a #\B) ==> #f
+#t
+(#<procedure CHAR_CI_GT> #\A #\b) ==> #f
+#t
+(#<procedure CHAR_CI_GT> #\a #\b) ==> #f
+#t
+(#<procedure CHAR_CI_GT> #\9 #\0) ==> #t
+#t
+(#<procedure CHAR_CI_GT> #\A #\A) ==> #f
+#t
+(#<procedure CHAR_CI_GT> #\A #\a) ==> #f
+#t
+(#<procedure CHAR_CI_LE> #\A #\B) ==> #t
+#t
+(#<procedure CHAR_CI_LE> #\a #\B) ==> #t
+#t
+(#<procedure CHAR_CI_LE> #\A #\b) ==> #t
+#t
+(#<procedure CHAR_CI_LE> #\a #\b) ==> #t
+#t
+(#<procedure CHAR_CI_LE> #\9 #\0) ==> #f
+#t
+(#<procedure CHAR_CI_LE> #\A #\A) ==> #t
+#t
+(#<procedure CHAR_CI_LE> #\A #\a) ==> #t
+#t
+(#<procedure CHAR_CI_GE> #\A #\B) ==> #f
+#t
+(#<procedure CHAR_CI_GE> #\a #\B) ==> #f
+#t
+(#<procedure CHAR_CI_GE> #\A #\b) ==> #f
+#t
+(#<procedure CHAR_CI_GE> #\a #\b) ==> #f
+#t
+(#<procedure CHAR_CI_GE> #\9 #\0) ==> #t
+#t
+(#<procedure CHAR_CI_GE> #\A #\A) ==> #t
+#t
+(#<procedure CHAR_CI_GE> #\A #\a) ==> #t
+#t
+(#<procedure CHAR_ALPHABETIC_P> #\a) ==> #t
+#t
+(#<procedure CHAR_ALPHABETIC_P> #\A) ==> #t
+#t
+(#<procedure CHAR_ALPHABETIC_P> #\z) ==> #t
+#t
+(#<procedure CHAR_ALPHABETIC_P> #\Z) ==> #t
+#t
+(#<procedure CHAR_ALPHABETIC_P> #\0) ==> #f
+#t
+(#<procedure CHAR_ALPHABETIC_P> #\9) ==> #f
+#t
+(#<procedure CHAR_ALPHABETIC_P> #\space) ==> #f
+#t
+(#<procedure CHAR_ALPHABETIC_P> #\;) ==> #f
+#t
+(#<procedure CHAR_NUMERIC_P> #\a) ==> #f
+#t
+(#<procedure CHAR_NUMERIC_P> #\A) ==> #f
+#t
+(#<procedure CHAR_NUMERIC_P> #\z) ==> #f
+#t
+(#<procedure CHAR_NUMERIC_P> #\Z) ==> #f
+#t
+(#<procedure CHAR_NUMERIC_P> #\0) ==> #t
+#t
+(#<procedure CHAR_NUMERIC_P> #\9) ==> #t
+#t
+(#<procedure CHAR_NUMERIC_P> #\space) ==> #f
+#t
+(#<procedure CHAR_NUMERIC_P> #\;) ==> #f
+#t
+(#<procedure CHAR_WHITESPACE_P> #\a) ==> #f
+#t
+(#<procedure CHAR_WHITESPACE_P> #\A) ==> #f
+#t
+(#<procedure CHAR_WHITESPACE_P> #\z) ==> #f
+#t
+(#<procedure CHAR_WHITESPACE_P> #\Z) ==> #f
+#t
+(#<procedure CHAR_WHITESPACE_P> #\0) ==> #f
+#t
+(#<procedure CHAR_WHITESPACE_P> #\9) ==> #f
+#t
+(#<procedure CHAR_WHITESPACE_P> #\space) ==> #t
+#t
+(#<procedure CHAR_WHITESPACE_P> #\;) ==> #f
+#t
+(#<procedure CHAR_UPPER_CASE_P> #\0) ==> #f
+#t
+(#<procedure CHAR_UPPER_CASE_P> #\9) ==> #f
+#t
+(#<procedure CHAR_UPPER_CASE_P> #\space) ==> #f
+#t
+(#<procedure CHAR_UPPER_CASE_P> #\;) ==> #f
+#t
+(#<procedure CHAR_LOWER_CASE_P> #\0) ==> #f
+#t
+(#<procedure CHAR_LOWER_CASE_P> #\9) ==> #f
+#t
+(#<procedure CHAR_LOWER_CASE_P> #\space) ==> #f
+#t
+(#<procedure CHAR_LOWER_CASE_P> #\;) ==> #f
+#t
+(#<procedure INTEGER_2_CHAR> 46) ==> #\.
+#t
+(#<procedure INTEGER_2_CHAR> 65) ==> #\A
+#t
+(#<procedure INTEGER_2_CHAR> 97) ==> #\a
+#t
+(#<procedure CHAR_UPCASE> #\A) ==> #\A
+#t
+(#<procedure CHAR_UPCASE> #\a) ==> #\A
+#t
+(#<procedure CHAR_DOWNCASE> #\A) ==> #\a
+#t
+(#<procedure CHAR_DOWNCASE> #\a) ==> #\a
+#t
+SECTION(6 7)
+#t
+(#<procedure STRING_P> "The word \"recursion\\\" has many meanings.") ==> #t
+#t
+(#<procedure STRING_P> "") ==> #t
+#t
+F
+(STRING-SET! "?**") ==> "?**"
+#t
+(#<procedure STRING> #\a #\b #\c) ==> "abc"
+#t
+(#<procedure STRING>) ==> ""
+#t
+(#<procedure STRING_LENGTH> "abc") ==> 3
+#t
+(#<procedure STRING_REF> "abc" 0) ==> #\a
+#t
+(#<procedure STRING_REF> "abc" 2) ==> #\c
+#t
+(#<procedure STRING_LENGTH> "") ==> 0
+#t
+(#<procedure SUBSTRING> "ab" 0 0) ==> ""
+#t
+(#<procedure SUBSTRING> "ab" 1 1) ==> ""
+#t
+(#<procedure SUBSTRING> "ab" 2 2) ==> ""
+#t
+(#<procedure SUBSTRING> "ab" 0 1) ==> "a"
+#t
+(#<procedure SUBSTRING> "ab" 1 2) ==> "b"
+#t
+(#<procedure SUBSTRING> "ab" 0 2) ==> "ab"
+#t
+(#<procedure STRING_APPEND> "foo" "bar") ==> "foobar"
+#t
+(#<procedure STRING_APPEND> "foo") ==> "foo"
+#t
+(#<procedure STRING_APPEND> "foo" "") ==> "foo"
+#t
+(#<procedure STRING_APPEND> "" "foo") ==> "foo"
+#t
+(#<procedure STRING_APPEND>) ==> ""
+#t
+(#<procedure MAKE_STRING> 0) ==> ""
+#t
+(#<procedure STRING_EQ> "" "") ==> #t
+#t
+(#<procedure STRING_LT> "" "") ==> #f
+#t
+(#<procedure STRING_GT> "" "") ==> #f
+#t
+(#<procedure STRING_LE> "" "") ==> #t
+#t
+(#<procedure STRING_GE> "" "") ==> #t
+#t
+(#<procedure STRING_CI_EQ> "" "") ==> #t
+#t
+(#<procedure STRING_CI_LT> "" "") ==> #f
+#t
+(#<procedure STRING_CI_GT> "" "") ==> #f
+#t
+(#<procedure STRING_CI_LE> "" "") ==> #t
+#t
+(#<procedure STRING_CI_GE> "" "") ==> #t
+#t
+(#<procedure STRING_EQ> "A" "B") ==> #f
+#t
+(#<procedure STRING_EQ> "a" "b") ==> #f
+#t
+(#<procedure STRING_EQ> "9" "0") ==> #f
+#t
+(#<procedure STRING_EQ> "A" "A") ==> #t
+#t
+(#<procedure STRING_LT> "A" "B") ==> #t
+#t
+(#<procedure STRING_LT> "a" "b") ==> #t
+#t
+(#<procedure STRING_LT> "9" "0") ==> #f
+#t
+(#<procedure STRING_LT> "A" "A") ==> #f
+#t
+(#<procedure STRING_GT> "A" "B") ==> #f
+#t
+(#<procedure STRING_GT> "a" "b") ==> #f
+#t
+(#<procedure STRING_GT> "9" "0") ==> #t
+#t
+(#<procedure STRING_GT> "A" "A") ==> #f
+#t
+(#<procedure STRING_LE> "A" "B") ==> #t
+#t
+(#<procedure STRING_LE> "a" "b") ==> #t
+#t
+(#<procedure STRING_LE> "9" "0") ==> #f
+#t
+(#<procedure STRING_LE> "A" "A") ==> #t
+#t
+(#<procedure STRING_GE> "A" "B") ==> #f
+#t
+(#<procedure STRING_GE> "a" "b") ==> #f
+#t
+(#<procedure STRING_GE> "9" "0") ==> #t
+#t
+(#<procedure STRING_GE> "A" "A") ==> #t
+#t
+(#<procedure STRING_CI_EQ> "A" "B") ==> #f
+#t
+(#<procedure STRING_CI_EQ> "a" "B") ==> #f
+#t
+(#<procedure STRING_CI_EQ> "A" "b") ==> #f
+#t
+(#<procedure STRING_CI_EQ> "a" "b") ==> #f
+#t
+(#<procedure STRING_CI_EQ> "9" "0") ==> #f
+#t
+(#<procedure STRING_CI_EQ> "A" "A") ==> #t
+#t
+(#<procedure STRING_CI_EQ> "A" "a") ==> #t
+#t
+(#<procedure STRING_CI_LT> "A" "B") ==> #t
+#t
+(#<procedure STRING_CI_LT> "a" "B") ==> #t
+#t
+(#<procedure STRING_CI_LT> "A" "b") ==> #t
+#t
+(#<procedure STRING_CI_LT> "a" "b") ==> #t
+#t
+(#<procedure STRING_CI_LT> "9" "0") ==> #f
+#t
+(#<procedure STRING_CI_LT> "A" "A") ==> #f
+#t
+(#<procedure STRING_CI_LT> "A" "a") ==> #f
+#t
+(#<procedure STRING_CI_GT> "A" "B") ==> #f
+#t
+(#<procedure STRING_CI_GT> "a" "B") ==> #f
+#t
+(#<procedure STRING_CI_GT> "A" "b") ==> #f
+#t
+(#<procedure STRING_CI_GT> "a" "b") ==> #f
+#t
+(#<procedure STRING_CI_GT> "9" "0") ==> #t
+#t
+(#<procedure STRING_CI_GT> "A" "A") ==> #f
+#t
+(#<procedure STRING_CI_GT> "A" "a") ==> #f
+#t
+(#<procedure STRING_CI_LE> "A" "B") ==> #t
+#t
+(#<procedure STRING_CI_LE> "a" "B") ==> #t
+#t
+(#<procedure STRING_CI_LE> "A" "b") ==> #t
+#t
+(#<procedure STRING_CI_LE> "a" "b") ==> #t
+#t
+(#<procedure STRING_CI_LE> "9" "0") ==> #f
+#t
+(#<procedure STRING_CI_LE> "A" "A") ==> #t
+#t
+(#<procedure STRING_CI_LE> "A" "a") ==> #t
+#t
+(#<procedure STRING_CI_GE> "A" "B") ==> #f
+#t
+(#<procedure STRING_CI_GE> "a" "B") ==> #f
+#t
+(#<procedure STRING_CI_GE> "A" "b") ==> #f
+#t
+(#<procedure STRING_CI_GE> "a" "b") ==> #f
+#t
+(#<procedure STRING_CI_GE> "9" "0") ==> #t
+#t
+(#<procedure STRING_CI_GE> "A" "A") ==> #t
+#t
+(#<procedure STRING_CI_GE> "A" "a") ==> #t
+#t
+SECTION(6 8)
+#t
+(#<procedure VECTOR_P> #(0 (2 2 2 2) "Anna")) ==> #t
+#t
+(#<procedure VECTOR_P> #()) ==> #t
+#t
+(#<procedure VECTOR> A B C) ==> #(A B C)
+#t
+(#<procedure VECTOR>) ==> #()
+#t
+(#<procedure VECTOR_LENGTH> #(0 (2 2 2 2) "Anna")) ==> 3
+#t
+(#<procedure VECTOR_LENGTH> #()) ==> 0
+#t
+(#<procedure VECTOR_REF> #(1 1 2 3 5 8 13 21) 5) ==> 8
+#t
+(VECTOR-SET #(0 ("Sue" "Sue") "Anna")) ==> #(0 ("Sue" "Sue") "Anna")
+#t
+(#<procedure MAKE_VECTOR> 2 HI) ==> #(HI HI)
+#t
+(#<procedure MAKE_VECTOR> 0) ==> #()
+#t
+(#<procedure MAKE_VECTOR> 0 A) ==> #()
+#t
+SECTION(6 9)
+#t
+(#<procedure PROCEDURE_P> #<procedure CAR>) ==> #t
+#t
+(#<procedure PROCEDURE_P> CAR) ==> #f
+#t
+(#<procedure PROCEDURE_P> #<interpreted function ???>) ==> #t
+#t
+(#<procedure PROCEDURE_P> (LAMBDA (X) (* X X))) ==> #f
+#t
+(#<procedure CALL_WITH_CURRENT_CONTINUATION> #<procedure PROCEDURE_P>) ==> #t
+#t
+(#<procedure APPLY> #<procedure ADD> (3 4)) ==> 7
+#t
+(#<procedure APPLY> #<interpreted function ???> (3 4)) ==> 7
+#t
+(#<procedure APPLY> #<procedure ADD> 10 (3 4)) ==> 17
+#t
+(#<procedure APPLY> #<procedure LIST> ()) ==> ()
+#t
+COMPOSE
+(#<interpreted function ???> 12 75) ==> 30
+#t
+(#<procedure MAP> #<procedure CXXR> ((A B) (D E) (G H))) ==> (B E H)
+#t
+(#<procedure MAP> #<procedure ADD> (1 2 3) (4 5 6)) ==> (5 7 9)
+#t
+(FOR-EACH #(0 1 4 9 16)) ==> #(0 1 4 9 16)
+#t
+(#<procedure CALL_WITH_CURRENT_CONTINUATION> #<interpreted function ???>) ==> -3
+#t
+LIST-LENGTH
+(#<interpreted function LIST-LENGTH> (1 2 3 4)) ==> 4
+#t
+(#<interpreted function LIST-LENGTH> (A B . C)) ==> #f
+#t
+(#<procedure MAP> #<procedure CXXR> ()) ==> ()
+#t
+NEXT-LEAF-GENERATOR
+LEAF-EQ?
+TEST-CONT
+TEST-DELAY
+SECTION(6 10 1)
+#t
+(#<procedure INPUT_PORT_P> #<input &input>) ==> #t
+#t
+(#<procedure OUTPUT_PORT_P> #<output &output>) ==> #t
+#t
+(#<procedure CALL_WITH_INPUT_FILE> "test.scm" #<procedure INPUT_PORT_P>) ==> #t
+#t
+THIS-FILE
+(#<procedure INPUT_PORT_P> #<input file(test.scm)>) ==> #t
+#t
+SECTION(6 10 2)
+#t
+(#<procedure PEEK_CHAR> #<input file(test.scm)>) ==> #\;
+#t
+(#<procedure READ_CHAR> #<input file(test.scm)>) ==> #\;
+#t
+(#<procedure READ> #<input file(test.scm)>) ==> (DEFINE CUR-SECTION (QUOTE ()))
+#t
+(#<procedure PEEK_CHAR> #<input file(test.scm)>) ==> #\(
+#t
+(#<procedure READ> #<input file(test.scm)>) ==> (DEFINE ERRS (QUOTE ()))
+#t
+#<input file(test.scm)>
+#<input file(test.scm)>
+CHECK-TEST-FILE
+SECTION(6 10 3)
+#t
+WRITE-TEST-OBJ
+DISPLAY-TEST-OBJ
+LOAD-TEST-OBJ
+(#<procedure CALL_WITH_OUTPUT_FILE> "tmp1" #<interpreted function ???>) ==> #t
+#t
+(#<procedure READ> #<input file(tmp1)>) ==> (DEFINE FOO (QUOTE (#t #f #\a () 9739 -3 . #((TEST) "te \" \" st" "" TEST #() B C))))
+(#<procedure EOF_OBJECT_P> #<eof>) ==> #t
+(#<procedure EOF_OBJECT_P> #<eof>) ==> #t
+(INPUT-PORT? #t) ==> #t
+(#<procedure READ_CHAR> #<input file(tmp1)>) ==> #\;
+(#<procedure READ> #<input file(tmp1)>) ==> (#t #f A () 9739 -3 . #((TEST) TE " " ST TEST #() B C))
+(#<procedure READ> #<input file(tmp1)>) ==> (DEFINE FOO (QUOTE (#t #f #\a () 9739 -3 . #((TEST) "te \" \" st" "" TEST #() B C))))
+#<input file(tmp1)>
+TEST-FILE
+#<output file(tmp2)>
+#<output file(tmp2)>
+#<output file(tmp2)>
+#<output file(tmp2)>
+(#<procedure OUTPUT_PORT_P> #<output file(tmp2)>) ==> #t
+#t
+#<output file(tmp2)>
+(#<procedure READ> #<input file(tmp2)>) ==> (DEFINE FOO (QUOTE (#t #f #\a () 9739 -3 . #((TEST) "te \" \" st" "" TEST #() B C))))
+(#<procedure EOF_OBJECT_P> #<eof>) ==> #t
+(#<procedure EOF_OBJECT_P> #<eof>) ==> #t
+(INPUT-PORT? #t) ==> #t
+(#<procedure READ_CHAR> #<input file(tmp2)>) ==> #\;
+(#<procedure READ> #<input file(tmp2)>) ==> (#t #f A () 9739 -3 . #((TEST) TE " " ST TEST #() B C))
+(#<procedure READ> #<input file(tmp2)>) ==> (DEFINE FOO (QUOTE (#t #f #\a () 9739 -3 . #((TEST) "te \" \" st" "" TEST #() B C))))
+#<input file(tmp2)>
+TEST-SC4
+
+Passed all tests
+#<output &output>
+
+;testing inexact numbers;
+SECTION(6 5 5)
+(#<procedure INEXACT_P> 3.9) ==> #t
+(INEXACT? #t) ==> #t
+(MAX 4.0) ==> 4.0
+(EXACT->INEXACT 4.0) ==> 4.0
+(#<procedure ROUND> -4.5) ==> -4.0
+(#<procedure ROUND> -3.5) ==> -4.0
+(#<procedure ROUND> -3.9) ==> -4.0
+(#<procedure ROUND> 0.0) ==> 0.0
+(#<procedure ROUND> 0.25) ==> 0.0
+(#<procedure ROUND> 0.8) ==> 1.0
+(#<procedure ROUND> 3.5) ==> 4.0
+(#<procedure ROUND> 4.5) ==> 4.0
+(#<procedure CALL_WITH_OUTPUT_FILE> "tmp3" #<interpreted function ???>) ==> #t
+(#<procedure READ> #<input file(tmp3)>) ==> (DEFINE FOO (QUOTE (0.25 -3.25)))
+(#<procedure EOF_OBJECT_P> #<eof>) ==> #t
+(#<procedure EOF_OBJECT_P> #<eof>) ==> #t
+(INPUT-PORT? #t) ==> #t
+(#<procedure READ_CHAR> #<input file(tmp3)>) ==> #\;
+(#<procedure READ> #<input file(tmp3)>) ==> (0.25 -3.25)
+(#<procedure READ> #<input file(tmp3)>) ==> (DEFINE FOO (QUOTE (0.25 -3.25)))
+(PENTIUM-FDIV-BUG #t) ==> #t
+
+Passed all tests
+#<output &output>
+
+;testing bignums;
+SECTION(6 5 5)
+(#<procedure MODULO> -2177452800 86400) ==> 0
+(#<procedure MODULO> 2177452800 -86400) ==> 0
+(#<procedure MODULO> 2177452800 86400) ==> 0
+(#<procedure MODULO> -2177452800 -86400) ==> 0
+(REMAINDER #t) ==> #t
+(REMAINDER #t) ==> #t
+SECTION(6 5 6)
+(#<procedure STRING_2_NUMBER> "281474976710655") ==> 281474976710655
+(#<procedure NUMBER_2_STRING> 281474976710655) ==> "281474976710655"
+
+Passed all tests
+#<output &output>
+
+#<output &output>
+To fully test continuations, Scheme 4, and DELAY/FORCE do:#<output &output>
+
+#<output &output>
+(test-cont) (test-sc4) (test-delay)#<output &output>
+
+#<output &output>
+"last item in file"
generated by cgit v1.2.3 (git 2.39.1) at 2024-06-02 03:58:26 +0000