Category : Files from Magazines
Archive   : AIAPR87.ZIP
Filename : AIAPP.APR

 
Output of file : AIAPP.APR contained in archive : AIAPR87.ZIP

"AI Apprentice"
April 1987 AI EXPERT magazine
(Listings to VTLISP)


VTLISP.PAS
----------

{.PW132}
{.IN+}
{.HE VTLISP.PAS Page #}
{$V-,R+ }
PROGRAM very_tiny_LISP ;

(* Copyright (c) 1987 - Knowledge Garden Inc.
473A Malden Bridge Rd.
RD #2
Nassau, NY 12123 *)


(* VT-LISP is a simple functional variation of LISP as described in the
April and May 1987 issues of AI Expert

This program has been tested using Turbo ver 3.01A on an IBM PC. It has
been run under both DOS 3.2 and Concurrent 5.0

We would be pleased to hear your comments, good or bad, or any applications
and modifications of the program. Contact us at:

AI Expert
CL Publications Inc.
500 Howard St.
San Francisco, CA 94105

or on the AI Expert BBS on Compuserv.
Our id is BillandBev Thompson ,[76703,4324].
You can also contact us on BIX, our id is bbt.

Bill and Bev Thompson *)

CONST
back_space = ^H ;
tab = ^I ;
eof_mark = ^Z ;
quote_char = #39 ;
left_arrow = #75 ;
return = ^M ;
bell = ^G ;

TYPE
counter = 0 .. maxint ;
222244444 string80 = string[80] ;
string132 = string[132] ;
string255 = string[255] ;
text_file = text ;
char_set = SET OF char ;
node_type = (cons_node,symbol,number,free_node) ;
s_expr = ^node ;
node = RECORD
in_use : boolean ;
CASE tag : node_type OF
cons_node : (car_ptr : s_expr ;
cdr_ptr : s_expr) ;
symbol : (string_data : string80) ;
number : (num_data : real) ;
free_node : (next_free : s_expr ;
block_cnt : counter) ;
END ;

(* node is the basic allocation unit for lists. The fields are used as
follows:

in_use - in_use = false tells the garbage collector that this node
is available for re-use.
tag - which kind of node this is.
cons_node - cons_nodes consist of two pointers. one to the head (first item)
the other to the rest of the list. They are the "glue" which
holds the list together. The list (A B C) would be stored as
------- -------- --------
| .| . |-----> | .| . |------> | .| . |---> NIL
--|----- --|------ --|-----
| | |
V V V
A B C

The boxes are the cons nodes, the first part of the box
holds the car pointer, then second contains the cdr pointer.
symbol - holds string values, we don't actually use the entire 80
characters in most cases.
number - used for storage of numbers. All numbers are implemented as
reals. This is inefficient, but relatively easy in Turbo
Pascal.
free_node - the garbage collector gathers all unused nodes and puts
them on a free list. It also compacts the free space into
contiguous blocks. next_free points to the next free block.
block_cnt contains a count of the number of contiguous 8 byte free
blocks which follow this one.


Note: we allocate a new node for each atom, instead of a pointer to an
existing string in the heap. This slows down comparisons,
because you have to compare strings instead of pointers, but
speeds up allocation. We've tried it both ways and there seems
to be no effect on small programs, but if you decide to
expand this program you should take a long hard look at all
of the allocation routines and improve them. *)


VAR
total_free : real ;
result,fn,free,initial_heap,saved_list,pending : s_expr ;
token : string80 ;
line,saved_line : string255 ;
delim_set : char_set ;
paren_level : counter ;

(* Variables - These are the important global variables:
total_free - a count of the total amount of free mameory on the
free list.
result - the S-expression returned by eval.
fn - S-expression read by get_expression.
free - a linked list of free nodes. Memory is allocated from
from here if possible before getting memory from
the heap. This list is built by the garbage collector.
inital_heap - a pointer to the bottom of the heap
saved_list - a list of all nodes which must absolutely not be
reclaimed by the garbage collector.
pending - a utility S-expression used by LETREC
token - the returned by get_token. This really shouldn't
be a global. It's just sloppy programming.
line - the input buffer for S-expressions
delim_set - set of token delimeters
paren_level - the count of unmatched parentheses, used while reading
S-expressions *)



(* ----------------------------------------------------------------------
Utility Routines
---------------------------------------------------------------------- *)


FUNCTION open(VAR f : text_file ; f_name : string80) : boolean ;
(* open a file - returns true if the file exists and was opened properly
f - file pointer
f_name - external name of the file *)
BEGIN
assign(f,f_name) ;
(*$I- *)
reset(f) ;
(*$I+ *)
open := (ioresult = 0) ;
END ; (* open *)


FUNCTION is_console(VAR f : text_file) : boolean ;
(* return true if f is open on the system console
for details of fibs and fib_ptrs see the Turbo Pascal ver 3.0 reference
manual chapter 20. This should work under CP/M-86 or 80, but we haven't
tried it. *)
TYPE
fib = ARRAY [0 .. 75] OF byte ;
VAR
fib_ptr : ^fib ;
dev_type : byte ;
BEGIN
fib_ptr := addr(f) ;
dev_type := fib_ptr^[2] AND $07 ;
is_console := (dev_type = 1) OR (dev_type = 2) ;
END ; (* is_console *)


PROCEDURE strip_leading_blanks(VAR s : string80) ;
BEGIN
IF length(s) > 0
THEN
IF (s[1] = ' ') OR (s[1] = tab)
THEN
BEGIN
delete(s,1,1) ;
strip_leading_blanks(s) ;
END ;
END ; (* strip_leading_blanks *)


PROCEDURE strip_trailing_blanks(VAR s : string80) ;
BEGIN
IF length(s) > 0
THEN
IF (s[length(s)] = ' ') OR (s[length(s)] = tab)
THEN
BEGIN
delete(s,length(s),1) ;
strip_trailing_blanks(s) ;
END ;
END ; (* strip_trailing_blanks *)



FUNCTION toupper(s : string80) : string80 ;
(* returns s converted to upper case *)
VAR
i : byte ;
BEGIN
IF length(s) > 0
THEN
FOR i := 1 TO length(s) DO
s[i] := upcase(s[i]) ;
toupper := s ;
END ; (* toupper *)



FUNCTION toreal(s : string255) : real ;
(* Converts "s" to a real - ignores non-numeric characters. *)
VAR
num : real ;
code : integer ;
BEGIN
strip_trailing_blanks(s) ;
strip_leading_blanks(s) ;
IF s = ''
THEN code := -1
ELSE IF length(s) = 1
THEN
IF s[1] IN ['0' .. '9']
THEN val(s,num,code)
ELSE code := -1
ELSE val(s,num,code) ;
IF code = 0
THEN toreal := num
ELSE toreal := 0 ;
END ; (* toreal *)


FUNCTION tointeger(s : string80) : integer ;
VAR
num : real ;
code : integer ;
BEGIN
strip_trailing_blanks(s) ;
strip_leading_blanks(s) ;
val(s,num,code) ;
IF code = 0
THEN
IF (num < -32768.0) OR (num > 32767.0)
THEN tointeger := 0
ELSE tointeger := trunc(num)
ELSE tointeger := 0 ;
END ; (* tointeger *)


FUNCTION is_number(s : string255) : boolean ;
VAR
num : real ;
code : integer ;
BEGIN
strip_trailing_blanks(s) ;
strip_leading_blanks(s) ;
IF s = ''
THEN code := -1
ELSE IF length(s) = 1
THEN
IF S[1] IN ['0' ..'9']
THEN code := 0
ELSE code := -1
ELSE val(s,num,code) ;
is_number := (code = 0) ;
END ; (* is_number *)


FUNCTION cardinal(i : integer) : real ;
VAR
r : real ;
BEGIN
r := i ;
IF r < 0
THEN r := r + 65536.0 ;
cardinal := r ;
END ; (* cardinal *)


FUNCTION tag_value(list : s_expr) : node_type ;
(* returns the value of the tag for a node. *)
BEGIN
IF list = NIL
THEN tag_value := free_node
ELSE tag_value := list^.tag ;
END ; (* tag_value *)


FUNCTION car(list : s_expr) : s_expr ;
(* returns a pointer to the first item in the list.
If the list is empty, it returns NIL. *)
BEGIN
IF list = NIL
THEN car := NIL
ELSE IF tag_value(list) = cons_node
THEN car := list^.car_ptr
ELSE car := NIL ;
END ; (* car *)


FUNCTION cdr(list : s_expr) : s_expr ;
(* returns a pointer to a list starting at the second item in the list.
Note - cdr( (a b c) ) points to the list (b c), but
cdr( ((a b) c d) ) points to the list (c d) . *)
BEGIN
IF list = NIL
THEN cdr := NIL
ELSE
CASE tag_value(list) OF
cons_node : cdr := list^.cdr_ptr ;
free_node : cdr := list^.next_free ;
ELSE cdr := NIL ;
END ;
END ; (* cdr *)


FUNCTION atom(p : s_expr) : boolean ;
(* Return true if p is a symbolic or numeric atom, otherwise
it returns false *)
BEGIN
IF p = NIL
THEN atom := false
ELSE IF tag_value(p) IN [number,symbol]
THEN atom := true
ELSE atom := false ;
END ; (* atom *)


FUNCTION allocation_size(x : integer) : integer ;
(* Turbo 3.0 allocates memory in 8 byte blocks, this routine calculates the
actual number of bytes returned for a request of x bytes. *)
BEGIN
allocation_size := (((x - 1) SHR 3) + 1) SHL 3 ;
END ; (* allocation_size *)


FUNCTION node_size : counter ;
(* calculates the size of a cons node. *)
BEGIN
node_size := 2 * sizeof(s_expr) + sizeof(boolean) + sizeof(node_type) ;
END ; (* node_size *)


FUNCTION normalize(pt : s_expr) : s_expr ;
(* returns a normalized pointer. Pointers are 32 bit addresses. The first
16 bits contain the segment number and the second 16 bits contain the
offset within the segment. Normalized pointers have offsets in the range
$0 to $F (0 .. 15) *)
VAR
pt_seg,pt_ofs : integer ;
BEGIN
pt_seg := seg(pt^) + (ofs(pt^) DIV 16) ;
pt_ofs := ofs(pt^) MOD 16 ;
normalize := ptr(pt_seg,pt_ofs) ;
END ; (* normalize *)



FUNCTION string_val(list : s_expr) : string80 ;
(* returns the string pointed to by list. If list points to a number
node, it returns a string representing that number *)
TYPE
real_rec = RECORD
CASE boolean OF
true : (p1 : real) ;
false : (p2 : ARRAY [0 ..5] OF byte) ;
END ;
VAR
s : string80 ;
p : real_rec ;

PROCEDURE strip_trailing_zeros(VAR ss : string80) ;
BEGIN
IF ss <> ''
THEN
IF ss[length(ss)] = '0'
THEN
BEGIN
delete(ss,length(ss),1) ;
strip_trailing_zeros(ss) ;
END ;
END ; (* strip_trailing_zeros *)

BEGIN
IF list = NIL
THEN string_val := ''
ELSE IF list^.tag = symbol
THEN string_val := list^.string_data
ELSE IF list^.tag = number
THEN
WITH list^ DO
BEGIN
p.p1 := abs(frac(num_data)) ;
IF p.p2[0] = 0
THEN str(num_data : 20 : 0,s)
ELSE IF p.p2[0] < 112
THEN str(num_data,s)
ELSE
BEGIN
str(num_data : 20 : 10,s) ;
strip_trailing_zeros(s) ;
END ;
strip_leading_blanks(s) ;
string_val := s ;
END
ELSE string_val := '' ;
END ; (* string_val *)


FUNCTION num_val(list : s_expr) : real ;
(* returns the number pointed to by list. If list points to a string,
it returns the numerical value of the string. *)
BEGIN
IF list = NIL
THEN num_val := 0.0
ELSE IF list^.tag = number
THEN num_val := list^.num_data
ELSE IF list^.tag = symbol
THEN num_val := toreal(list^.string_data)
ELSE num_val := 0.0 ;
END ; (* num_val *)



PROCEDURE get_memory(VAR p : s_expr ; size : counter) ;
(* On exit p contains a pointer to a block of allocation_size(size) bytes.
If possible this routine tries to get memory from the free list before
requesting it from the heap *)
VAR
blks : counter ;
allocated : boolean ;

PROCEDURE get_from_free(VAR list : s_expr) ;
(* Try and get need memory from the free list. This routine uses a
first-fit algorithm to get the space. It takes the first free block it
finds with enough storage. If the free block has more storage than was
requested, the block is shrunk by the requested amount. *)
BEGIN
IF list <> NIL
THEN
IF list^.block_cnt >= (blks - 1)
THEN
BEGIN
p := normalize(ptr(seg(list^),ofs(list^) +
(list^.block_cnt - blks + 1) * 8)) ;
IF list^.block_cnt = blks - 1
THEN list := list^.next_free
ELSE list^.block_cnt := list^.block_cnt - blks ;
allocated := true ;
total_free := total_free - (blks * 8.0) ;
END
ELSE get_from_free(list^.next_free) ;
END ; (* get_from_free *)

BEGIN
blks := ((size - 1) DIV 8) + 1 ;
allocated := false ;
get_from_free(free) ;
IF NOT allocated
THEN getmem(p,blks * 8) ;
END ; (* get_memory *)


FUNCTION alloc_str(s : string80) : s_expr ;
(* Allocate storage for a string and return a pointer to the new node.
This routine only allocates enough storage for the actual number of
characters in the string plus one for the length. Because of this,
concatenating anything to the end of a string stored in a symbol node
will lead to disaster. Copy the string to a new string do the
concatenation and then allocate a new node. *)
VAR
pt : s_expr ;
BEGIN
get_memory(pt,allocation_size(sizeof(node_type) + sizeof(boolean) +
length(s) + 1)) ;
pt^.tag := symbol ;
pt^.string_data := s ;
alloc_str := pt ;
END ; (* alloc_str *)


FUNCTION alloc_num(r : real) : s_expr ;
(* Allocate storage for a number and return a pointer to the new node.
All numbers are stored as reals. This isn't efficient, but it is
easy. *)
VAR
pt : s_expr ;
BEGIN
get_memory(pt,allocation_size(sizeof(node_type) + sizeof(boolean) +
sizeof(real))) ;
pt^.tag := number ;
pt^.num_data := r ;
alloc_num := pt ;
END ; (* alloc_num *)


FUNCTION cons(new_node,list : s_expr) : s_expr ;
(* Construct a list. This routine allocates storage for a new cons node.
new_node points to the new car of the list. The cdr pointer of the
new node points to list. This routine adds the new cons node to the
beginning of the list and returns a pointer to it. The list described
in the comments at the beginning of the program could be constructed
as cons(alloc_str('A'),cons(alloc_str('B'),cons(alloc_str('C'),NIL))). *)
VAR
p : s_expr ;
BEGIN
get_memory(p,allocation_size(node_size)) ;
p^.tag := cons_node ;
p^.car_ptr := new_node ;
p^.cdr_ptr := list ;
cons := p ;
END ; (* cons *)


FUNCTION eq(item1,item2 : s_expr) : boolean ;
(* test the equality of two atoms, if item1 and item2 are not atoms
it returns false *)
BEGIN
IF (item1 = NIL) AND (item2 = NIL)
THEN eq := true
ELSE IF (tag_value(item1) IN [number,symbol]) AND
(tag_value(item2) IN [number,symbol])
THEN eq := (string_val(item1) = string_val(item2))
ELSE eq := false ;
END ; (* eq *)


FUNCTION lt(item1,item2 : s_expr) : boolean ;
(* tests if item1 < item2, if item1 and item2 are not atoms
it returns false *)
BEGIN
IF (item1 = NIL) AND (item2 = NIL)
THEN lt := false
ELSE IF (tag_value(item1) IN [number,symbol]) AND
(tag_value(item2) IN [number,symbol])
THEN lt := (string_val(item1) < string_val(item2))
ELSE lt := false ;
END ; (* lt *)


FUNCTION gt(item1,item2 : s_expr) : boolean ;
(* tests if item1 > item2, if item1 and item2 are not atoms
it returns false *)
BEGIN
IF (item1 = NIL) AND (item2 = NIL)
THEN gt := false
ELSE IF (tag_value(item1) IN [number,symbol]) AND
(tag_value(item2) IN [number,symbol])
THEN gt := (string_val(item1) > string_val(item2))
ELSE gt := false ;
END ; (* gt *)


FUNCTION add(item1,item2 : s_expr) : s_expr ;
(* add the values of two atoms, if item1 and item2 are not atoms
it returns 0 *)
VAR
r1,r2 : real ;
BEGIN
IF tag_value(item1) = number
THEN r1 := num_val(item1)
ELSE r1 := toreal(string_val(item1)) ;
IF tag_value(item2) = number
THEN r2 := num_val(item2)
ELSE r2 := toreal(string_val(item2)) ;
add := alloc_num(r1 + r2) ;
END ; (* add *)


FUNCTION sub(item1,item2 : s_expr) : s_expr ;
(* finds the difference between the values of two atoms,
if item1 and item2 are not atoms it returns 0 *)
VAR
r1,r2 : real ;
BEGIN
IF tag_value(item1) = number
THEN r1 := num_val(item1)
ELSE r1 := toreal(string_val(item1)) ;
IF tag_value(item2) = number
THEN r2 := num_val(item2)
ELSE r2 := toreal(string_val(item2)) ;
sub := alloc_num(r1 - r2) ;
END ; (* sub *)


FUNCTION mul(item1,item2 : s_expr) : s_expr ;
(* finds the product of the values of two atoms,
if item1 and item2 are not atoms it returns 0 *)
VAR
r1,r2 : real ;
BEGIN
IF tag_value(item1) = number
THEN r1 := num_val(item1)
ELSE r1 := toreal(string_val(item1)) ;
IF tag_value(item2) = number
THEN r2 := num_val(item2)
ELSE r2 := toreal(string_val(item2)) ;
mul := alloc_num(r1 * r2) ;
END ; (* mul *)


FUNCTION div_f(item1,item2 : s_expr) : s_expr ;
(* divides item1 by item2,
if item1 and item2 are not atoms it returns 0 *)
VAR
r1,r2 : real ;
BEGIN
IF tag_value(item1) = number
THEN r1 := num_val(item1)
ELSE r1 := toreal(string_val(item1)) ;
IF tag_value(item2) = number
THEN r2 := num_val(item2)
ELSE r2 := toreal(string_val(item2)) ;
IF abs(r2) <= 1.0E-20
THEN div_f := alloc_num(0.0)
ELSE div_f := alloc_num(r1 / r2) ;
END ; (* div_f *)


FUNCTION mod_f(item1,item2 : s_expr) : s_expr ;
(* finds the remainder of item1 divided by item2,
if item1 and item2 are not atoms it returns 0 *)
VAR
r1,r2 : integer ;
BEGIN
r1 := tointeger(string_val(item1)) ;
r2 := tointeger(string_val(item2)) ;
mod_f := alloc_num(r1 MOD r2) ;
END ; (* mod_f *)


FUNCTION member(p,list : s_expr) : boolean ;
(* returns true if p points to a member of list *)
BEGIN
IF list = NIL
THEN member := false
ELSE IF eq(p,car(list))
THEN member := true
ELSE member := member(p,cdr(list)) ;
END ; (* member *)


FUNCTION locate(p,list1,list2 : s_expr) : s_expr ;
(* finds p on list1 and returns a pointer to the corresponding
element of list2 *)
BEGIN
IF list1 = NIL
THEN locate := NIL
ELSE IF eq(p,car(list1))
THEN locate := car(list2)
ELSE locate := locate(p,cdr(list1),cdr(list2)) ;
END ; (* locate *)


FUNCTION assoc(p,list1,list2 : s_expr) : s_expr ;
(* search each sublist of list1 for p. If found, return pointer to
corresponding element of list2 *)
BEGIN
IF list1 = NIL
THEN assoc := NIL
ELSE IF member(p,car(list1))
THEN assoc := locate(p,car(list1),car(list2))
ELSE assoc := assoc(p,cdr(list1),cdr(list2)) ;
END ; (* assoc *)


FUNCTION tf_node(t : boolean) : s_expr ;
(* allocates T or F nodes for boolean expressions *)
BEGIN
IF t
THEN tf_node := alloc_str('T')
ELSE tf_node := alloc_str('F') ;
END ; (* tf_node *)


FUNCTION rplaca(VAR list : s_expr ; item : s_expr) : s_expr ;
(* replace the car of list with item, return a pointer to the new list *)
BEGIN
IF list <> NIL
THEN
IF tag_value(list) <> cons_node
THEN list := item
ELSE list^.car_ptr := item ;
rplaca := list ;
END ; (* rplaca *)


PROCEDURE collect_garbage ;
(* This routine is specific to Turbo Pascal Ver 3.01
It depends upon the fact that Turbo allocates memory in 8 byte blocks
on the PC. If you recompile this program on another system be very
careful with this routine.
Garbage collection proceeds in three phases:
unmark - free all memory between the initial_heap^ and the current
top of the heap.
mark_mem - mark everything on the saved_list as being in ues.
release - gather all unmarked blocks and put them on the free list.
The collector displays a '*' on the screen to let you know it is
operating. *)

FUNCTION lower(p1,p2 : s_expr) : boolean ;
(* returns true if p1 points to a lower memory address than p2 *)
BEGIN
p1 := normalize(p1) ;
p2 := normalize(p2) ;
lower := (cardinal(seg(p1^)) < cardinal(seg(p2^))) OR
((seg(p1^) = seg(p2^)) AND
(cardinal(ofs(p1^)) < cardinal(ofs(p2^)))) ;
END ; (* lower *)

PROCEDURE mark_mem(list : s_expr) ;
(* Mark the blocks on list as being in use. Since a node may be on several
lists at one time, if it is already marked we don't continue processing
the cdr of the list. *)
BEGIN
IF list <> NIL
THEN
BEGIN
IF NOT list^.in_use
THEN
BEGIN
list^.in_use := true ;
IF list^.tag = cons_node
THEN
BEGIN
mark_mem(car(list)) ;
mark_mem(cdr(list)) ;
END ;
END ;
END ;
END ; (* mark_mem *)

PROCEDURE unmark_mem ;
(* Go through memory from initial_heap^ to HeapPtr^ and mark each node
as not in use. The tricky part here is updating the pointer p to point
to the next cell. *)
VAR
p : s_expr ;
string_base,node_allocation,number_allocation : integer ;
BEGIN
string_base := sizeof(node_type) + sizeof(boolean) ;
p := normalize(initial_heap) ;
node_allocation := allocation_size(node_size) ;
number_allocation := allocation_size(sizeof(node_type) + sizeof(boolean) +
sizeof(real)) ;
WHILE lower(p,HeapPtr) DO
BEGIN
p^.in_use := false ;
CASE p^.tag OF
cons_node : p := normalize(ptr(seg(p^),ofs(p^) + node_allocation)) ;
free_node : p := normalize(ptr(seg(p^),ofs(p^) + (p^.block_cnt + 1) * 8)) ;
number : p := normalize(ptr(seg(p^),ofs(p^) + number_allocation)) ;
symbol : p := normalize(ptr(seg(p^),
ofs(p^) +
allocation_size(string_base +
length(p^.string_data) + 1))) ;
END ;
END ;
END ; (* unmark_mem *)

PROCEDURE release_mem ;
(* This procedure does the actual collection and compaction of nodes.
This is the slow phase of garbage collection because of all the pointer
manipulation. *)
VAR
heap_top : s_expr ;
string_base,node_allocation,string_allocation,block_allocation,
number_allocation : integer ;

PROCEDURE free_memory(pt : s_expr ; size : counter) ;
(* return size bytes pointed to by pt to the free list. If pt points to
a block next to the car of the free list combine it with the top
free node. total_free keeps track of the total number of free bytes. *)
VAR
blks : counter ;
BEGIN
blks := ((size - 1) DIV 8) + 1 ;
pt^.tag := free_node ;
IF normalize(ptr(seg(pt^),ofs(pt^) + 8 * blks)) = free
THEN
BEGIN
pt^.next_free := free^.next_free ;
pt^.block_cnt := free^.block_cnt + blks ;
free := pt ;
END
ELSE IF normalize(ptr(seg(free^),ofs(free^) + 8 * (free^.block_cnt + 1))) =
normalize(pt)
THEN free^.block_cnt := free^.block_cnt + blks
ELSE
BEGIN
pt^.next_free := free ;
pt^.block_cnt := blks - 1 ;
free := pt ;
END ;
total_free := total_free + (blks * 8.0) ;
END ; (* free_memory *)

PROCEDURE do_release ;
(* This routine sweeps through memory and checks for nodes with
in_use = false. *)
VAR
p : s_expr ;
BEGIN
p := normalize(initial_heap) ;
WHILE lower(p,heap_top) DO
CASE p^.tag OF
cons_node : BEGIN
IF NOT p^.in_use
THEN free_memory(p,node_size) ;
p := normalize(ptr(seg(p^),ofs(p^) + node_allocation)) ;
END ;
free_node : BEGIN
block_allocation := (p^.block_cnt + 1) * 8 ;
free_memory(p,block_allocation) ;
p := normalize(ptr(seg(p^),ofs(p^) + block_allocation)) ;
END ;
number : BEGIN
IF NOT p^.in_use
THEN free_memory(p,number_allocation) ;
p := normalize(ptr(seg(p^),ofs(p^) + number_allocation)) ;
END ;
symbol : BEGIN
string_allocation := allocation_size(string_base +
length(p^.string_data) + 1) ;
IF NOT p^.in_use
THEN free_memory(p,string_base + length(p^.string_data)
+ 1) ;
p := normalize(ptr(seg(p^),ofs(p^) + string_allocation)) ;
END ;
END ;
END ; (* do_release *)

BEGIN
free := NIL ;
total_free := 0.0 ;
heap_top := HeapPtr ;
string_base := sizeof(node_type) + sizeof(boolean) ;
node_allocation := allocation_size(node_size) ;
number_allocation := allocation_size(sizeof(node_type) + sizeof(boolean) +
sizeof(real)) ;
do_release ;
END ; (* release_mem *)

BEGIN
write('*') ;
unmark_mem ;
mark_mem(saved_list) ;
release_mem ;
write(back_space) ;
clreol ;
END ; (* collect_garbage *)


PROCEDURE test_memory ;
(* This routine activates the garbage collector, if the the total available
memory (free_list + heap) is less than a specified amount. Lowering the
minimum causes garbage collection to be called less often, but if you
make it too small you may not have enough room left for recursion or any
temporary lists you need. Using 10000 is probably being overly
cautious. *)
BEGIN
IF (memavail * 16.0) + total_free < 10000
THEN collect_garbage ;
END ; (* test_memory *)


PROCEDURE wait ;
(* Just like it says. It waits for the user to press a key before
continuing. *)
VAR
ch : char ;
BEGIN
writeln ;
writeln ;
write('Press any key to continue. ') ;
read(kbd,ch) ;
write(return) ;
clreol ;
END ; (* wait *)


(* ------------------------------------------------------------------------
End of utility routines
------------------------------------------------------------------------ *)

PROCEDURE read_kbd(VAR s : string80) ;
(* Read a line from the keyboard. The number of unmatched parentheses are
printed along with the prompt *)
BEGIN
IF paren_level > 0
THEN write(paren_level,'>')
ELSE write('-> ') ;
readln(s) ;
END ; (* read_kbd *)


PROCEDURE read_from_file(VAR f : text_file) ;
(* Read a line from file f and store it in the global variable line.
It ignores blank lines and when the end of file is reached an
eof_mark is returned. *)

PROCEDURE read_a_line ;
BEGIN
(*$I- *)
readln(f,line) ;
(*$I+ *)
IF ioresult <> 0
THEN line := eof_mark
ELSE IF eof(f)
THEN line := concat(line,eof_mark) ;
END ; (* read_a_line *)

BEGIN
line := '' ;
IF is_console(f)
THEN read_kbd(line)
ELSE read_a_line ;
saved_line := line ;
END ; (* read_from_file *)


PROCEDURE get_token(VAR t_line : string255 ; VAR token : string80) ;
(* Get a token from t_line. A token is a string of text surrounded by
blanks or a delimeter. Comments begin with ; and extend to the
end of the line *)

PROCEDURE get_word ;
VAR
done : boolean ;
cn : integer ;
len : byte ;
BEGIN
cn := 1 ;
len := length(t_line) ;
done := false ;
WHILE NOT done DO
IF cn > len
THEN done := true
ELSE IF t_line[cn] IN delim_set
THEN done := true
ELSE cn := cn + 1 ;
token := copy(t_line,1,cn-1) ;
delete(t_line,1,cn-1) ;
END ; (* get_word *)

PROCEDURE comment ;
BEGIN
t_line := '' ;
get_token(t_line,token) ;
END ; (* comment *)

PROCEDURE get_number ;

PROCEDURE get_digits ;
BEGIN
WHILE is_number(copy(t_line,1,1))
BEGIN
token := concat(token,t_line[1]) ;
delete(t_line,1,1) ;
END ;
END ; (* get_digits *)

PROCEDURE get_exponent ;
BEGIN
delete(t_line,1,1) ;
IF length(t_line) > 0
THEN
BEGIN
IF t_line[1] IN ['+','-']
THEN
BEGIN
token := concat(token,'E',t_line[1]) ;
delete(t_line,1,1) ;
END
ELSE token := concat(token,'E+') ;
get_digits ;
END
ELSE token := concat(token,'E+00') ;
END ; (* get_exponent *)

BEGIN
get_digits ;
IF length(t_line) > 0
THEN
IF t_line[1] = '.'
THEN
IF is_number(copy(t_line,2,1))
THEN
BEGIN
token := concat(token,t_line[1]) ;
delete(t_line,1,1) ;
get_digits ;
IF toupper(copy(t_line,1,1)) = 'E'
THEN get_exponent ;
END ;
END ; (* get_number *)

PROCEDURE check_number ;
VAR
sgn : char ;
BEGIN
sgn := t_line[1] ;
delete(t_line,1,1) ;
IF length(t_line) > 0
THEN
IF t_line[1] IN ['0' .. '9']
THEN
BEGIN
get_number ;
token := concat(sgn,token) ;
END
ELSE token := sgn
ELSE token := sgn ;
END ; (* check_number *)

BEGIN
strip_leading_blanks(t_line) ;
token := '' ;
IF length(t_line) > 0
THEN
BEGIN
IF t_line[1] = ';'
THEN comment
ELSE IF t_line[1] IN delim_set
THEN
BEGIN
token := t_line[1] ;
delete(t_line,1,1) ;
END
ELSE IF t_line[1] IN ['+','-']
THEN check_number
ELSE IF t_line[1] IN ['0' .. '9']
THEN get_number
ELSE get_word ;
END ;
END ; (* get_token *)


PROCEDURE scan(VAR f : text_file ; VAR token : string80) ;
(* Scan repeatedly calls get_token to retreive tokens. When the
end of a line has been reached, read_from_file is called to
get a new line. *)
BEGIN
IF length(line) > 0
THEN
BEGIN
get_token(line,token) ;
IF token = ''
THEN scan(f,token) ;
END
ELSE
BEGIN
read_from_file(f) ;
scan(f,token) ;
END ;
END ; (* scan *)


PROCEDURE error(error_msg : string80) ;
BEGIN
writeln ;
writeln(error_msg) ;
wait ;
END ; (* error *)


FUNCTION get_expression_list(VAR f : text_file) : s_expr ; FORWARD ;


FUNCTION get_expression(VAR f : text_file) : s_expr ;
(* read an expression from f. This routine and get_expression_list
work together to form a small recursive descent compiler for
S-expressions. It follows the definition fo an S-expression
from the article. It adds a quote to numbers and strings beginning with
a ' mark *)
BEGIN
IF token = '('
THEN
BEGIN
scan(f,token) ;
paren_level := paren_level + 1 ;
get_expression := get_expression_list(f) ;
IF token <> ')'
THEN error('Missing '')''') ;
END
ELSE IF token = quote_char
THEN
BEGIN
scan(f,token) ;
get_expression := cons(alloc_str('QUOTE'),cons(get_expression(f),NIL)) ;
END
ELSE IF toupper(token) = 'NIL'
THEN get_expression := NIL
ELSE IF is_number(token)
THEN get_expression := cons(alloc_str('QUOTE'),
cons(alloc_num(toreal(token)),NIL))
ELSE get_expression := alloc_str(token) ;
END ; (* get_expression *)


FUNCTION get_expression_list (* VAR f : text_file) : s_expr *) ;
(* read an S-expression list or dotted pair *)
VAR
p : s_expr ;
BEGIN
p := get_expression(f) ;
scan(f,token) ;
IF token = '.'
THEN
BEGIN
scan(f,token) ;
get_expression_list := cons(p,get_expression(f)) ;
scan(f,token) ;
END
ELSE IF token = ')'
THEN
BEGIN
paren_level := paren_level - 1 ;
get_expression_list := cons(p,NIL) ;
END
ELSE get_expression_list := cons(p,get_expression_list(f)) ;
END ; (* get_expression_list *)


PROCEDURE print_expression(l : s_expr) ;
(* recursively traverses the list and prints its elements. This is
not a pretty printer, so the lists may look a bit messy. This routine
tries to print the minimum possible number of parentheses. *)

PROCEDURE print_list(list : s_expr) ;
VAR
p : s_expr ;
BEGIN
IF list <> NIL
THEN
CASE list^.tag OF
number,
symbol : write(string_val(list),' ') ;
cons_node : BEGIN
write('(') ;
p := list ;
WHILE tag_value(p) = cons_node DO
BEGIN
print_list(car(p)) ;
p := cdr(p) ;
END ;
IF p <> NIL
THEN
BEGIN
write('. ') ;
print_list(p) ;
END ;
write(') ') ;
END ;
END ;
END ; (* print_list *)

BEGIN
IF l = NIL
THEN write('nil ')
ELSE print_list(l) ;
END ; (* print_expression *)


FUNCTION eval(expr_list,name_list,value_list : s_expr) : s_expr ;
(* The main evaluation routine. This routine is explained in the articles.
expr_list contains the S-expression to be evaluated. name_list is the
list of active variable names. value_list is the list of corresponding
values. expr_list,name_list and value_list are attached to saved_list
at the start of the routine so that if garbage collection takes place
they won't be reclaimed. They are removed at the end of this routine. *)
VAR
f_name : string80 ;

FUNCTION vars(list : s_expr) : s_expr ;
(* make a list of variables from list *)
BEGIN
IF list = NIL
THEN vars := NIL
ELSE vars := cons(car(car(list)),vars(cdr(list))) ;
END ; (* vars *)

FUNCTION exprs(list : s_expr) : s_expr ;
(* make a list of expressions *)
BEGIN
IF list = NIL
THEN exprs := NIL
ELSE exprs := cons(car(cdr(car(list))),exprs(cdr(list))) ;
END ; (* exprs *)

FUNCTION eval_list(list,name,value : s_expr) : s_expr ;
(* evaluate a list, one item at a time. It does this by calling eval
for each element of list *)
BEGIN
IF list = NIL
THEN eval_list := NIL
ELSE eval_list := cons(eval(car(list),name,value),
eval_list(cdr(list),name,value)) ;
END ; (* eval_list *)

FUNCTION eval_if : s_expr ;
BEGIN
IF string_val(eval(car(cdr(expr_list)),name_list,value_list)) = 'T'
THEN eval_if := eval(car(cdr(cdr(expr_list))),name_list,value_list)
ELSE eval_if := eval(car(cdr(cdr(cdr(expr_list)))),name_list,
value_list)
END ; (* eval_if *)

FUNCTION eval_let : s_expr ;
VAR
y,z : s_expr ;
BEGIN
y := vars(cdr(cdr(expr_list))) ;
z := eval_list(exprs(cdr(cdr(expr_list))),name_list,value_list) ;
eval_let := eval(car(cdr(expr_list)),cons(y,name_list),
cons(z,value_list)) ;
END ; (* eval_let *)

FUNCTION eval_letrec : s_expr ;
VAR
v,y,z : s_expr ;
BEGIN
v := cons(cons(pending,NIL),value_list) ;
y := vars(cdr(cdr(expr_list))) ;
z := eval_list(exprs(cdr(cdr(expr_list))),cons(y,name_list),v) ;
eval_letrec := eval(car(cdr(expr_list)),cons(y,name_list),
rplaca(v,z)) ;
END ; (* eval_letrec *)

FUNCTION eval_read : s_expr ;
(* read an expression from a file. The file must end in ".LSP".
That's because we were too lazy to implement strings. The expression
read from the file is evaluated. *)
VAR
f : text_file ;
file_name : string80 ;
old_line,old_saved_line : string255 ;
BEGIN
file_name := string_val(eval(car(cdr(expr_list)),name_list,value_list)) ;
IF pos('.',file_name) = 0
THEN file_name := concat(file_name,'.LSP') ;
IF open(f,file_name)
THEN
BEGIN
old_line := line ;
old_saved_line := saved_line ;
line := '' ;
scan(f,token) ;
eval_read := eval(get_expression(f),name_list,value_list) ;
close(f) ;
line := old_line ;
saved_line := old_saved_line ;
END
ELSE
BEGIN
error(concat('Unable to read ',file_name)) ;
eval_read := NIL ;
END ;
END ; (* eval_read *)

FUNCTION eval_f_call : s_expr ;
(* evaluate a function call *)
VAR
c,z : s_expr ;
BEGIN
c := eval(car(expr_list),name_list,value_list) ;
z := eval_list(cdr(expr_list),name_list,value_list) ;
eval_f_call := eval(cdr(car(c)),cons(car(car(c)),car(cdr(c))),
cons(z,cdr(cdr(c)))) ;
END ; (* eval_f_call *)

BEGIN
saved_list := cons(expr_list,cons(name_list,cons(value_list,saved_list))) ;
test_memory ;
IF expr_list = NIL
THEN eval := NIL
ELSE IF atom(expr_list)
THEN eval := assoc(expr_list,name_list,value_list)
ELSE
BEGIN
f_name := toupper(string_val(car(expr_list))) ;
IF f_name = 'QUOTE'
THEN eval := car(cdr(expr_list))
ELSE IF f_name = 'CAR'
THEN eval := car(eval(car(cdr(expr_list)),name_list,value_list))
ELSE IF f_name = 'CDR'
THEN eval := cdr(eval(car(cdr(expr_list)),name_list,value_list))
ELSE IF f_name = 'ATOM'
THEN eval := tf_node(atom(eval(car(cdr(expr_list)),name_list,
value_list)))
ELSE IF f_name = 'CONS'
THEN eval := cons(eval(car(cdr(expr_list)),name_list,value_list),
eval(car(cdr(cdr(expr_list))),name_list,value_list))
ELSE IF f_name = 'EQ'
THEN eval := tf_node(eq(eval(car(cdr(expr_list)),name_list,value_list),
eval(car(cdr(cdr(expr_list))),name_list,value_list)))
ELSE IF f_name = 'LT'
THEN eval := tf_node(lt(eval(car(cdr(expr_list)),name_list,value_list),
eval(car(cdr(cdr(expr_list))),name_list,value_list)))
ELSE IF f_name = 'GT'
THEN eval := tf_node(gt(eval(car(cdr(expr_list)),name_list,value_list),
eval(car(cdr(cdr(expr_list))),name_list,value_list)))
ELSE IF f_name = 'NEQ'
THEN eval := tf_node(NOT eq(eval(car(cdr(expr_list)),name_list,value_list),
eval(car(cdr(cdr(expr_list))),name_list,
value_list)))
ELSE IF (f_name = '+') OR (f_name = 'ADD')
THEN eval := add(eval(car(cdr(expr_list)),name_list,value_list),
eval(car(cdr(cdr(expr_list))),name_list,value_list))
ELSE IF (f_name = '-') OR (f_name = 'SUB')
THEN eval := sub(eval(car(cdr(expr_list)),name_list,value_list),
eval(car(cdr(cdr(expr_list))),name_list,value_list))
ELSE IF (f_name = '*') OR (f_name = 'MUL')
THEN eval := mul(eval(car(cdr(expr_list)),name_list,value_list),
eval(car(cdr(cdr(expr_list))),name_list,value_list))
ELSE IF (f_name = '/') OR (f_name = 'DIV')
THEN eval := div_f(eval(car(cdr(expr_list)),name_list,value_list),
eval(car(cdr(cdr(expr_list))),name_list,value_list))
ELSE IF f_name = 'MOD'
THEN eval := mod_f(eval(car(cdr(expr_list)),name_list,value_list),
eval(car(cdr(cdr(expr_list))),name_list,value_list))
ELSE IF f_name = 'IF'
THEN eval := eval_if
ELSE IF f_name = 'LAMBDA'
THEN eval := cons(cons(car(cdr(expr_list)),car(cdr(cdr(expr_list)))),
cons(name_list,value_list))
ELSE IF f_name = 'LET'
THEN eval := eval_let
ELSE IF f_name = 'LETREC'
THEN eval := eval_letrec
ELSE IF f_name = 'EXIT'
THEN halt(0)
ELSE IF f_name = 'READ'
THEN eval := eval_read
ELSE eval := eval_f_call ;
END ;
saved_list := cdr(cdr(cdr(saved_list))) ;
END ; (* eval *)


PROCEDURE initialize ;
BEGIN
line := '' ;
saved_line := '' ;
delim_set := ['.','(',')',' ',eof_mark,quote_char,';'] ;
total_free := 0.0 ;
paren_level := 0 ;
free := NIL ;
mark(initial_heap) ;
pending := alloc_str('#PENDING') ;
saved_list := cons(pending,NIL) ;
clrscr ;
writeln('VT-LISP - Copyright 1987 [c] Knowledge Garden Inc.') ;
END ; (* initialize *)


BEGIN
initialize ;
REPEAT
scan(input,token) ;
fn := get_expression(input) ;
result := eval(fn,NIL,NIL) ;
print_expression(result) ;
writeln ;
UNTIL false ;
END.



DIFF.LSP
--------

;
; Diff - symbolic diferentiation - From Henderson - Functional Programming
; enter S-expressions such as (* x c) and returns its derivative
;
(letrec (diff '(+ x c))
(diff (lambda (e)
(if (atom e)
(if (eq e 'x) 1 0)
(if (eq (car e) '+)
(let (sum (diff p1) (diff p2))
(p1 (car (cdr e)))
(p2 (car (cdr (cdr e)))))
(if (eq (car e) '*)
(let (sum (prod p1 (diff p2))
(prod (diff p1) p2))
(p1 (car (cdr e)))
(p2 (car (cdr (cdr e)))))
'error)))))
(sum (lambda (u v)
(cons '+ (cons u (cons v nil)))))
(prod (lambda (u v)
(cons '* (cons u (cons v nil))))))


LAST.LSP
--------

;
; last - find the last element of a list
;
(letrec (last '(a b c d e))
(last (lambda (x)
(if (eq (cdr x) nil) x
(last (cdr x))))))


APPEND.LSP
----------

;
; Append one list to another
; Usage (append expr1 expr2) - change the lists in the letrec statement
;
(letrec (append '(a b c) '(d e f g h i j k l m n o p))
(append (lambda (x y)
(if (eq x nil) y
(cons (car x) (append (cdr x) y))))))


------------------------------------------------------------------------


S-expression ::- atom | '(' expression-list ')'
atom ::- text-string | number
expression-list ::- S-expression | S-expression '.' S-expression |
S-expression expression-list

Figure 1
The definition of S-expressions. "::-" means "is defined as" and "|"
means "OR".

__________________________________________________________________________

Variable
x

Constants
(QUOTE s)
's

Arithmetic expressions
(ADD expr1 expr2) (+ expr1 expr2)
(SUB expr1 expr2) (- expr1 expr2)
(MUL expr1 expr2) (* expr1 expr2)
(DIV expr1 expr2) (/ expr1 expr2)
(MOD expr1 expr2)

Comparisons
(EQ expr1 expr2)
(LEQ expr1 expr2)
(GEQ expr1 expr2)
(NEQ expr1 expr2)

S-expression operations
(CONS expr1 expr2)
(CAR expr)
(CDR expr)
(ATOM expr)

Conditional expression
(IF expr1 expr2 expr3)

Return to DOS
(EXIT)

Definition expressions
(LAMBDA (x1 x2 x3 ....) expr)
(LET expr (x1.expr1) (x2.expr2) .......)
(LETREC expr (x1.expr1) (x2.expr2) ......)

Function Call
(expr expr1 expr2 expr3 ...)

Figure 2
VT-LISP statements.
x's represent variables, expr's represent S-expressions.


  3 Responses to “Category : Files from Magazines
Archive   : AIAPR87.ZIP
Filename : AIAPP.APR

  1. Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!

  2. This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.

  3. But one thing that puzzles me is the “mtswslnkmcjklsdlsbdmMICROSOFT” string. There is an article about it here. It is definitely worth a read: http://www.os2museum.com/wp/mtswslnk/