Thread View: pe.cust.sources
1 messages
1 total messages
Started by Earl Wallace
Thu, 13 Jun 1985 19:54
Little Smalltalk Source, *New* Part 14 of 20
Author: Earl Wallace
Date: Thu, 13 Jun 1985 19:54
Date: Thu, 13 Jun 1985 19:54
2249 lines
55474 bytes
55474 bytes
#! /bin/sh
#
# This is an another posting of the Little Smalltalk source, the last posting
# of this source went out in 5 parts and they were too big (>200k) for most
# sites so I redid the whole mess to keep the files around the 50k range.
#
# The complete set is now 20 parts.
#
# P.S. - If you don't receive all 20 parts within 5 days, drop me a line.
# Also, I have the Rand sources of May 1984, if someone has a more
# updated copy, I'll be happy to post them (or YOU can post them :-))
#
# -earlw@pesnta
#
#! /bin/sh
# This is a shell archive, meaning:
# 1. Remove everything above the #! /bin/sh line.
# 2. Save the resulting text in a file.
# 3. Execute the file with /bin/sh (not csh) to create the files:
# projects/primitive.h
# projects/prob.st
# projects/prob.uniform
# projects/sim.1
# projects/sim.2
# projects/sim.3
# projects/simulat.result
# projects/simulation.bun
# projects/switch.st
# projects/visitor.st
# sources/Makefile
# sources/array.c
# sources/block.c
# sources/block.h
# sources/byte.c
# sources/byte.h
# sources/class.c
# sources/cldict.c
# sources/courier.c
# sources/disclaim
# This archive created: Thu Jun 13 11:32:46 1985
# By: Earl Wallace (Perkin-Elmer Data Systems Group / Customer Service)
export PATH; PATH=/bin:$PATH
if test -f 'projects/primitive.h'
then
echo shar: will not over-write existing file "'projects/primitive.h'"
else
cat << \SHAR_EOF > 'projects/primitive.h'
/*
Little Smalltalk primitive definitions
(only a subset of primitives are described here,
basically those used by the courier and other systems routines.
All other primitives are known only by number)
*/
# define EQTEST 7
# define GAMMAFUN 77
# define SYMEQTEST 91
# define SYMPRINT 94
# define FINDCLASS 99
# define GROW 113
# define BLKRETERROR 127
# define REFCOUNTERROR 128
# define NORESPONDERROR 129
# define RAWPRINT 120
# define PRINT 121
# define ERRPRINT 123
# define DIEPRIMITIVE 140
# define BLOCKEXECUTE 142
# define GETSENDER 145
SHAR_EOF
if test 554 -ne "`wc -c < 'projects/primitive.h'`"
then
echo shar: error transmitting "'projects/primitive.h'" '(should have been 554 characters)'
fi
fi # end of overwriting check
if test -f 'projects/prob.st'
then
echo shar: will not over-write existing file "'projects/prob.st'"
else
cat << \SHAR_EOF > 'projects/prob.st'
Class DiscreteProbability
| randnum |
[
initialize
randnum <- Random new
| next
^ self inverseDistribution: randnum next
| computeSample: m outOf: n
m > n ifTrue: [^ 0.0]
^ n factorial / (n - m) factorial
]
Class Geometric :DiscreteProbability
| prob |
[
mean: m
prob <- m
| mean
^ 1.0 / prob
| variance
^ (1.0 - prob) / prob * prob
| density: x
x > 0 ifTrue: [^prob * ((1.0-prob) raisedTo: x-1)]
ifFalse: [^1.0]
| inverseDistribution: x
^ (x ln / (1.0 - prob) ln) ceiling
]
Class Binomial :DiscreteProbability
| number prob |
[
events: num mean: p
(p between: 0.0 and: 1.0)
ifFalse: [self error: 'mean must be > 0'].
number <- num.
prob <- p
| mean
^ prob
| variance
^ prob * (1 - prob)
| density: x
(x between: 0.0 and number)
ifTrue: [^((self computeSample: x outOf: number)
/ (self computeSample: x outOf: x))
* (prob raisedTo: x) * ((1 - prob) raisedTo: number - x)]
ifFalse: [^0.0]
| inverseDistribution: x
x <= prob
ifTrue: [^ 1]
ifFalse: [^ 0]
| next
| t |
t <- 0.
number timesRepeat: [t <- t + super next].
^ t
]
SHAR_EOF
if test 1118 -ne "`wc -c < 'projects/prob.st'`"
then
echo shar: error transmitting "'projects/prob.st'" '(should have been 1118 characters)'
fi
fi # end of overwriting check
if test -f 'projects/prob.uniform'
then
echo shar: will not over-write existing file "'projects/prob.uniform'"
else
cat << \SHAR_EOF > 'projects/prob.uniform'
Class ProbabilityDistribution :Stream
[
new "create instance"
^ self basicNew
| next "random sampling"
^ self inverseDistribution: U next
| density: x "is the density func"
self subclassResponsibility
| distribution: aCollection "cum prob func, arg range of vals"
self subclassResponsibility
| inverseDistribution: x
self subclassResponsibility
| computeSample: m outOf: n
m > n ifTrue: [^0.0]
^ n factorial / (n - m) factorial
]
Class ContinuousProbability :ProbabilityDistribution
[
distribution: aCollection
| t aStream x1 x2 y1 y2 |
t <- 0.0.
aStream <- ReadStream on: aCollection.
x2 <- aStream next.
y2 <- self density: x2.
[x1 <- x2. x2 <- aStream next]
whileTrue:
[y1 <- y2.
y2 <- self density: x2.
t <- t + ((x2 - x1) * (y2 + y1))].
^ t * 0.5
]
Class Uniform :ContinuousProbability
| startNumber stopNumber |
[
from: begin to: end
begin > end
ifTrue: [self error "illegal interval"]
ifFalse: [^ self new setStart: begin toEnd: end]
| mean
^ (startNumber + stopNumber) / 2
| variance
^ (stopNumber + startNumber) squared / 12
| density: x
(x between: startNumber and: stopNumber)
ifTrue: [^1.0 / (stopNumber - startNumber)]
ifFalse: [^0]
| inverseDistribution: x
^ startNumber + (x * (stopNumber - startNumber))
| setStart: begin toEnd: end
startNumber <- begin.
stopNumber <- end
]
SHAR_EOF
if test 1396 -ne "`wc -c < 'projects/prob.uniform'`"
then
echo shar: error transmitting "'projects/prob.uniform'" '(should have been 1396 characters)'
fi
fi # end of overwriting check
if test -f 'projects/sim.1'
then
echo shar: will not over-write existing file "'projects/sim.1'"
else
cat << \SHAR_EOF > 'projects/sim.1'
Class Simulation :Object
| currentTime action aProbDist totalProfit |
[
initialize
currentTime <- 0.0.
totalProfit <- 0
| scheduleArrivalOf: actionBlock
accordingTo: aProbabilityDistribution
action <- actionBlock.
aProbDist <- aProbabilityDistribution
| startUp
self initialize.
self defineArrivalSchedule
| proceed
currentTime <- currentTime + aProbDist next.
action value
| time
^ currentTime
| thisProfit: aNumber
totalProfit <- totalProfit + aNumber
| reportProfit
totalProfit print
| defineArrivalSchedule
| customer profit |
self scheduleArrivalOf: [customer <- Visitor new init.
profit <- customer numberScoops * 40 / 100.
self thisProfit: profit]
accordingTo: Random new
]
Class Visitor :Object
| random |
[
init
random <- Random new
| numberScoops
| scoops |
scoops <- 1 / (random next).
^ scoops
]
SHAR_EOF
if test 876 -ne "`wc -c < 'projects/sim.1'`"
then
echo shar: error transmitting "'projects/sim.1'" '(should have been 876 characters)'
fi
fi # end of overwriting check
if test -f 'projects/sim.2'
then
echo shar: will not over-write existing file "'projects/sim.2'"
else
cat << \SHAR_EOF > 'projects/sim.2'
Class Simulation :Object
| currentTime eventQueue numberChairs newVisitor superVisitor numberServed
visitorProbDist missedGroup totalProfit profitMargin coneCost |
[
startUp
self initialize.
self defineArrivalSchedule.
superVisitor <- SimulationObject new init.
eventQueue at: self timeNextVisitor
put: (newVisitor value: superVisitor)
| initialize
currentTime <- 0.0.
numberChairs <- 12.
profitMargin <- 0.75.
coneCost <- 0.70.
totalProfit <- 0.
numberServed <- 0.
missedGroup <- 0.
eventQueue <- Dictionary new
| defineArrivalSchedule
self scheduleArrivalOf:
[:superV | Visitor new initialize: superV]
accordingTo: (Geometric new initialize mean: 24 / 60)
| scheduleArrivalOf: aVisitor
accordingTo: aProbabilityDistribution
newVisitor <- aVisitor.
visitorProbDist <- aProbabilityDistribution
| timeNextVisitor
^ currentTime + visitorProbDist next
| time
^ currentTime
| proceed
| visitor minTime |
eventQueue at: self timeNextVisitor
put: (newVisitor value: superVisitor).
minTime <- 999999.
eventQueue keysDo: [:x | x < minTime
ifTrue: [minTime <- x] ].
visitor <- eventQueue removeKey: minTime ifAbsent:
(self error: 'no visitor in eventQueue').
self incrTime: minTime.
(visitor entering)
ifTrue: [(visitor groupSize <= numberChairs)
ifTrue: [self tasks: visitor]
ifFalse: [self missed: visitor groupSize]
]
ifFalse: [self releaseChairs: visitor groupSize]
| incrTime: aNumber
currentTime <- currentTime + aNumber
| tasks: aVisitor
self served: aVisitor groupSize.
self takeChairs: aVisitor groupSize.
self thisProfit: aVisitor groupSize * 1.5 *
coneCost * profitMargin. "1.5 cones/person"
eventQueue at: currentTime + aVisitor time put: aVisitor
| served: aNumber
numberServed <- numberServed + aNumber
| takeChairs: aNumber
numberChairs <- numberChairs - aNumber
| releaseChairs: aNumber
numberChairs <- numberChairs + aNumber
| missed: aNumber
missedGroup <- missedGroup + aNumber
| report
'total profit' print.
totalProfit print.
'number of people served' print.
numberServed print.
'number of people turned away' print.
missedGroup print
| thisProfit: aNumber
totalProfit <- totalProfit + aNumber
]
Class Visitor :SimulationObject
| sizeGroup wait alreadyEaten |
[
initialize: superClass
sizeGroup <- superClass size.
wait <- superClass wait: sizeGroup.
alreadyEaten <- false
| entering
(alreadyEaten == false)
ifTrue: [alreadyEaten <- true. ^ true].
^ false
| time
^ wait
| groupSize
^ sizeGroup
]
Class SimulationObject :Object
| sizeDist waitDist |
[
init
sizeDist <- Binomial new initialize events: 5 mean: 0.4.
waitDist <- Random new "uniform distribution"
| size
^ sizeDist next
| wait: sizeGroup "uniform distribution from 1 to 6"
^ waitDist next * sizeGroup * 6
]
SHAR_EOF
if test 2927 -ne "`wc -c < 'projects/sim.2'`"
then
echo shar: error transmitting "'projects/sim.2'" '(should have been 2927 characters)'
fi
fi # end of overwriting check
if test -f 'projects/sim.3'
then
echo shar: will not over-write existing file "'projects/sim.3'"
else
cat << \SHAR_EOF > 'projects/sim.3'
Class Simulation :Object
| currentTime eventQueue resources newVisitor superVisitor visitorProbDist |
[
startUp
self initialize.
self defineArrivalSchedule.
superVisitor <- SimulationObject new init.
self addNextEvent
| initialize
currentTime <- 0.0.
eventQueue <- Dictionary new
| initResources: aNumber
resources <- aNumber
| scheduleArrivalOf: aVisitor
accordingTo: aProbabilityDistribution
newVisitor <- aVisitor.
visitorProbDist <- aProbabilityDistribution
| timeNextVisitor
^ currentTime + visitorProbDist next
| time
^ currentTime
| proceed
| visitor minTime |
minTime <- 999999.
eventQueue keysDo: [:x | x < minTime
ifTrue: [minTime <- x] ].
visitor <- eventQueue removeKey: minTime ifAbsent:
(self error: 'no visitor in eventQueue').
currentTime <- minTime.
self tasks: visitor.
self addNextEvent
| addNextEvent
eventQueue at: self timeNextVisitor
put: (newVisitor value: superVisitor)
| delay: visitor for: time
eventQueue at: currentTime + time put: visitor
| numResources
^ resources
| takeResources: aNumber
resources <- resources - aNumber
| releaseResources: aNumber
resources <- resources + aNumber
]
Class IceCreamStore :Simulation
| numberChairs missedGroup servedGroup totalProfit profitMargin coneCost |
[
initialize
super initialize.
servedGroup <- 0.
missedGroup <- 0.
totalProfit <- 0.
profitMargin <- 0.75.
coneCost <- 0.70.
numberChairs <- 8.
super initResources: numberChairs
| defineArrivalSchedule
super scheduleArrivalOf:
[:superV | Visitor new initialize: superV]
accordingTo: (Geometric new initialize mean: 14 / 60)
"expect 18 parties per hour"
| tasks: visitor
(visitor entering)
ifTrue: [(visitor groupSize <= super numResources)
ifTrue: [self getIceCream: visitor]
ifFalse: [self missed: visitor groupSize]
]
ifFalse: [self releaseChairs: visitor groupSize]
| getIceCream: aVisitor
self served: aVisitor groupSize.
self takeChairs: aVisitor groupSize.
self thisProfit: aVisitor groupSize * 1.5 *
coneCost * profitMargin. "1.5 cones/person"
super delay: aVisitor for: aVisitor time
| takeChairs: aNumber
super takeResources: aNumber
| releaseChairs: aNumber
super releaseResources: aNumber
| missed: aNumber
missedGroup <- missedGroup + aNumber
| served: aNumber
servedGroup <- servedGroup + aNumber
| thisProfit: aNumber
totalProfit <- totalProfit + aNumber
| report
'total profit' print.
totalProfit print.
'number of people served' print.
servedGroup print.
'number of people turned away' print.
missedGroup print
]
SHAR_EOF
if test 2693 -ne "`wc -c < 'projects/sim.3'`"
then
echo shar: error transmitting "'projects/sim.3'" '(should have been 2693 characters)'
fi
fi # end of overwriting check
if test -f 'projects/simulat.result'
then
echo shar: will not over-write existing file "'projects/simulat.result'"
else
cat << \SHAR_EOF > 'projects/simulat.result'
time: 35
profit: 13.38
served: 17
turned away: 23
SHAR_EOF
if test 50 -ne "`wc -c < 'projects/simulat.result'`"
then
echo shar: error transmitting "'projects/simulat.result'" '(should have been 50 characters)'
fi
fi # end of overwriting check
if test -f 'projects/simulation.bun'
then
echo shar: will not over-write existing file "'projects/simulation.bun'"
else
cat << \SHAR_EOF > 'projects/simulation.bun'
: To unbundle, sh this file
echo unbundling prob.st 1>&2
cat >prob.st <<'End'
Class DiscreteProbability
| randnum |
[
initialize
randnum <- Random new
| next
^ self inverseDistribution: randnum next
| computeSample: m outOf: n
m > n ifTrue: [^ 0.0]
^ n factorial / (n - m) factorial
]
Class Geometric :DiscreteProbability
| prob |
[
mean: m
prob <- m
| mean
^ 1.0 / prob
| variance
^ (1.0 - prob) / prob * prob
| density: x
x > 0 ifTrue: [^prob * ((1.0-prob) raisedTo: x-1)]
ifFalse: [^1.0]
| inverseDistribution: x
^ (x ln / (1.0 - prob) ln) ceiling
]
Class Binomial :DiscreteProbability
| number prob |
[
events: num mean: p
(p between: 0.0 and: 1.0)
ifFalse: [self error: 'mean must be > 0'].
number <- num.
prob <- p
| mean
^ prob
| variance
^ prob * (1 - prob)
| density: x
(x between: 0.0 and number)
ifTrue: [^((self computeSample: x outOf: number)
/ (self computeSample: x outOf: x))
* (prob raisedTo: x) * ((1 - prob) raisedTo: number - x)]
ifFalse: [^0.0]
| inverseDistribution: x
x <= prob
ifTrue: [^ 1]
ifFalse: [^ 0]
| next
| t |
t <- 0.
number timesRepeat: [t <- t + super next].
^ t
]
End
echo unbundling prob.uniform 1>&2
cat >prob.uniform <<'End'
Class ProbabilityDistribution :Stream
[
new "create instance"
^ self basicNew
| next "random sampling"
^ self inverseDistribution: U next
| density: x "is the density func"
self subclassResponsibility
| distribution: aCollection "cum prob func, arg range of vals"
self subclassResponsibility
| inverseDistribution: x
self subclassResponsibility
| computeSample: m outOf: n
m > n ifTrue: [^0.0]
^ n factorial / (n - m) factorial
]
Class ContinuousProbability :ProbabilityDistribution
[
distribution: aCollection
| t aStream x1 x2 y1 y2 |
t <- 0.0.
aStream <- ReadStream on: aCollection.
x2 <- aStream next.
y2 <- self density: x2.
[x1 <- x2. x2 <- aStream next]
whileTrue:
[y1 <- y2.
y2 <- self density: x2.
t <- t + ((x2 - x1) * (y2 + y1))].
^ t * 0.5
]
Class Uniform :ContinuousProbability
| startNumber stopNumber |
[
from: begin to: end
begin > end
ifTrue: [self error "illegal interval"]
ifFalse: [^ self new setStart: begin toEnd: end]
| mean
^ (startNumber + stopNumber) / 2
| variance
^ (stopNumber + startNumber) squared / 12
| density: x
(x between: startNumber and: stopNumber)
ifTrue: [^1.0 / (stopNumber - startNumber)]
ifFalse: [^0]
| inverseDistribution: x
^ startNumber + (x * (stopNumber - startNumber))
| setStart: begin toEnd: end
startNumber <- begin.
stopNumber <- end
]
End
echo unbundling sim.1 1>&2
cat >sim.1 <<'End'
Class Simulation :Object
| currentTime action aProbDist totalProfit |
[
initialize
currentTime <- 0.0.
totalProfit <- 0
| scheduleArrivalOf: actionBlock
accordingTo: aProbabilityDistribution
action <- actionBlock.
aProbDist <- aProbabilityDistribution
| startUp
self initialize.
self defineArrivalSchedule
| proceed
currentTime <- currentTime + aProbDist next.
action value
| time
^ currentTime
| thisProfit: aNumber
totalProfit <- totalProfit + aNumber
| reportProfit
totalProfit print
| defineArrivalSchedule
| customer profit |
self scheduleArrivalOf: [customer <- Visitor new init.
profit <- customer numberScoops * 40 / 100.
self thisProfit: profit]
accordingTo: Random new
]
Class Visitor :Object
| random |
[
init
random <- Random new
| numberScoops
| scoops |
scoops <- 1 / (random next).
^ scoops
]
End
echo unbundling sim.2 1>&2
cat >sim.2 <<'End'
Class Simulation :Object
| currentTime eventQueue numberChairs newVisitor superVisitor numberServed
visitorProbDist missedGroup totalProfit profitMargin coneCost |
[
startUp
self initialize.
self defineArrivalSchedule.
superVisitor <- SimulationObject new init.
eventQueue at: self timeNextVisitor
put: (newVisitor value: superVisitor)
| initialize
currentTime <- 0.0.
numberChairs <- 12.
profitMargin <- 0.75.
coneCost <- 0.70.
totalProfit <- 0.
numberServed <- 0.
missedGroup <- 0.
eventQueue <- Dictionary new
| defineArrivalSchedule
self scheduleArrivalOf:
[:superV | Visitor new initialize: superV]
accordingTo: (Geometric new initialize mean: 24 / 60)
| scheduleArrivalOf: aVisitor
accordingTo: aProbabilityDistribution
newVisitor <- aVisitor.
visitorProbDist <- aProbabilityDistribution
| timeNextVisitor
^ currentTime + visitorProbDist next
| time
^ currentTime
| proceed
| visitor minTime |
eventQueue at: self timeNextVisitor
put: (newVisitor value: superVisitor).
minTime <- 999999.
eventQueue keysDo: [:x | x < minTime
ifTrue: [minTime <- x] ].
visitor <- eventQueue removeKey: minTime ifAbsent:
(self error: 'no visitor in eventQueue').
self incrTime: minTime.
(visitor entering)
ifTrue: [(visitor groupSize <= numberChairs)
ifTrue: [self tasks: visitor]
ifFalse: [self missed: visitor groupSize]
]
ifFalse: [self releaseChairs: visitor groupSize]
| incrTime: aNumber
currentTime <- currentTime + aNumber
| tasks: aVisitor
self served: aVisitor groupSize.
self takeChairs: aVisitor groupSize.
self thisProfit: aVisitor groupSize * 1.5 *
coneCost * profitMargin. "1.5 cones/person"
eventQueue at: currentTime + aVisitor time put: aVisitor
| served: aNumber
numberServed <- numberServed + aNumber
| takeChairs: aNumber
numberChairs <- numberChairs - aNumber
| releaseChairs: aNumber
numberChairs <- numberChairs + aNumber
| missed: aNumber
missedGroup <- missedGroup + aNumber
| report
'total profit' print.
totalProfit print.
'number of people served' print.
numberServed print.
'number of people turned away' print.
missedGroup print
| thisProfit: aNumber
totalProfit <- totalProfit + aNumber
]
Class Visitor :SimulationObject
| sizeGroup wait alreadyEaten |
[
initialize: superClass
sizeGroup <- superClass size.
wait <- superClass wait: sizeGroup.
alreadyEaten <- false
| entering
(alreadyEaten == false)
ifTrue: [alreadyEaten <- true. ^ true].
^ false
| time
^ wait
| groupSize
^ sizeGroup
]
Class SimulationObject :Object
| sizeDist waitDist |
[
init
sizeDist <- Binomial new initialize events: 5 mean: 0.4.
waitDist <- Random new "uniform distribution"
| size
^ sizeDist next
| wait: sizeGroup "uniform distribution from 1 to 6"
^ waitDist next * sizeGroup * 6
]
End
echo unbundling sim.3 1>&2
cat >sim.3 <<'End'
Class Simulation :Object
| currentTime eventQueue resources newVisitor superVisitor visitorProbDist |
[
startUp
self initialize.
self defineArrivalSchedule.
superVisitor <- SimulationObject new init.
self addNextEvent
| initialize
currentTime <- 0.0.
eventQueue <- Dictionary new
| initResources: aNumber
resources <- aNumber
| scheduleArrivalOf: aVisitor
accordingTo: aProbabilityDistribution
newVisitor <- aVisitor.
visitorProbDist <- aProbabilityDistribution
| timeNextVisitor
^ currentTime + visitorProbDist next
| time
^ currentTime
| proceed
| visitor minTime |
minTime <- 999999.
eventQueue keysDo: [:x | x < minTime
ifTrue: [minTime <- x] ].
visitor <- eventQueue removeKey: minTime ifAbsent:
(self error: 'no visitor in eventQueue').
currentTime <- minTime.
self tasks: visitor.
self addNextEvent
| addNextEvent
eventQueue at: self timeNextVisitor
put: (newVisitor value: superVisitor)
| delay: visitor for: time
eventQueue at: currentTime + time put: visitor
| numResources
^ resources
| takeResources: aNumber
resources <- resources - aNumber
| releaseResources: aNumber
resources <- resources + aNumber
]
Class IceCreamStore :Simulation
| numberChairs missedGroup servedGroup totalProfit profitMargin coneCost |
[
initialize
super initialize.
servedGroup <- 0.
missedGroup <- 0.
totalProfit <- 0.
profitMargin <- 0.75.
coneCost <- 0.70.
numberChairs <- 8.
super initResources: numberChairs
| defineArrivalSchedule
super scheduleArrivalOf:
[:superV | Visitor new initialize: superV]
accordingTo: (Geometric new initialize mean: 14 / 60)
"expect 18 parties per hour"
| tasks: visitor
(visitor entering)
ifTrue: [(visitor groupSize <= super numResources)
ifTrue: [self getIceCream: visitor]
ifFalse: [self missed: visitor groupSize]
]
ifFalse: [self releaseChairs: visitor groupSize]
| getIceCream: aVisitor
self served: aVisitor groupSize.
self takeChairs: aVisitor groupSize.
self thisProfit: aVisitor groupSize * 1.5 *
coneCost * profitMargin. "1.5 cones/person"
super delay: aVisitor for: aVisitor time
| takeChairs: aNumber
super takeResources: aNumber
| releaseChairs: aNumber
super releaseResources: aNumber
| missed: aNumber
missedGroup <- missedGroup + aNumber
| served: aNumber
servedGroup <- servedGroup + aNumber
| thisProfit: aNumber
totalProfit <- totalProfit + aNumber
| report
'total profit' print.
totalProfit print.
'number of people served' print.
servedGroup print.
'number of people turned away' print.
missedGroup print
]
End
echo unbundling simulat.results 1>&2
cat >simulat.results <<'End'
time: 35
profit: 13.38
served: 17
turned away: 23
End
echo unbundling visitor.st 1>&2
cat >visitor.st <<'End'
Class SimulationObject :Object
| sizeDist waitDist |
[
init
sizeDist <- Binomial new initialize events: 5 mean: 0.4.
waitDist <- Random new "uniform distribution"
| size
^ sizeDist next
| wait: sizeGroup "uniform distribution from 1 to 6"
^ waitDist next * sizeGroup * 6
]
Class Visitor :SimulationObject
| sizeGroup wait alreadyEaten |
[
initialize: superClass
sizeGroup <- superClass size.
wait <- superClass wait: sizeGroup.
alreadyEaten <- false
| entering
(alreadyEaten == false)
ifTrue: [alreadyEaten <- true. ^ true].
^ false
| time
^ wait
| groupSize
^ sizeGroup
]
End
SHAR_EOF
if test 10103 -ne "`wc -c < 'projects/simulation.bun'`"
then
echo shar: error transmitting "'projects/simulation.bun'" '(should have been 10103 characters)'
fi
fi # end of overwriting check
if test -f 'projects/switch.st'
then
echo shar: will not over-write existing file "'projects/switch.st'"
else
cat << \SHAR_EOF > 'projects/switch.st'
Class Switch
| key found |
[
new: aKey
found <- false.
key <- aKey
|
case: test do: aBlock
(key = test) ifTrue: [found <- true. aBlock value]
|
default: aBlock
found ifFalse: aBlock
]
SHAR_EOF
if test 196 -ne "`wc -c < 'projects/switch.st'`"
then
echo shar: error transmitting "'projects/switch.st'" '(should have been 196 characters)'
fi
fi # end of overwriting check
if test -f 'projects/visitor.st'
then
echo shar: will not over-write existing file "'projects/visitor.st'"
else
cat << \SHAR_EOF > 'projects/visitor.st'
Class SimulationObject :Object
| sizeDist waitDist |
[
init
sizeDist <- Binomial new initialize events: 5 mean: 0.4.
waitDist <- Random new "uniform distribution"
| size
^ sizeDist next
| wait: sizeGroup "uniform distribution from 1 to 6"
^ waitDist next * sizeGroup * 6
]
Class Visitor :SimulationObject
| sizeGroup wait alreadyEaten |
[
initialize: superClass
sizeGroup <- superClass size.
wait <- superClass wait: sizeGroup.
alreadyEaten <- false
| entering
(alreadyEaten == false)
ifTrue: [alreadyEaten <- true. ^ true].
^ false
| time
^ wait
| groupSize
^ sizeGroup
]
SHAR_EOF
if test 617 -ne "`wc -c < 'projects/visitor.st'`"
then
echo shar: error transmitting "'projects/visitor.st'" '(should have been 617 characters)'
fi
fi # end of overwriting check
if test -f 'sources/Makefile'
then
echo shar: will not over-write existing file "'sources/Makefile'"
else
cat << \SHAR_EOF > 'sources/Makefile'
CFLAGS =-O
LFLAGS =-n
LIB = -lm
BINDIR = ../bin
PARSEDIR = ../parser
Objects = main.o object.o line.o \
class.o number.o symbol.o string.o byte.o array.o file.o \
primitive.o syms.o cldict.o process.o interp.o block.o courier.o \
lex.o drive.o lexcmd.o
Objects.c = main.c object.c line.c \
class.c number.c symbol.c string.c byte.c array.c file.c \
primitive.c syms.c cldict.c process.c interp.c block.c courier.c \
lex.c drive.c lexcmd.c
MISC = disclaim Makefile *.h sstr.c symbols
st: sstr drive.h cmds.h env.h $(Objects)
cc ${CFLAGS} $(LFLAGS) -o st $(Objects) $(LIB)
# the following is used by st make script for installation on the DecPro 350
# ld -o st -X -u __doprnt -u fltused -u fptrap -m \
# -lfpsim /lib/fcrt0.o $(Objects) -lm -lc
install: st
mv st $(BINDIR)
bundle: $(MISC) $(Objects.c)
rm -f drive.h cmds.h env.h
bundle $(MISC) $(Objects.c) >../sources.bundle
lint.out:$(Objects.c)
lint $(Objects.c)
syms.c: sstr symbols
sstr -t symbols SYMTABMAX '# include "object.h"' '# include "symbol.h"' >syms.c
sstr: sstr.c
cc ${CFLAGS} $(LFLAGS) -o sstr sstr.c
drive.h: $(PARSEDIR)/drive.h symbols
cp $(PARSEDIR)/drive.h .
cmds.h: $(PARSEDIR)/cmds.h symbols
sstr symbols <$(PARSEDIR)/cmds.h >cmds.h
env.h: $(PARSEDIR)/env.h
cp $(PARSEDIR)/env.h .
number.o: number.c number.h
interp.o: drive.h cmds.h
primitive.o: *.h
main.o: *.h
clean:
-rm -f ${Objects} sstr drive.h cmds.h env.h
SHAR_EOF
if test 1410 -ne "`wc -c < 'sources/Makefile'`"
then
echo shar: error transmitting "'sources/Makefile'" '(should have been 1410 characters)'
fi
fi # end of overwriting check
if test -f 'sources/array.c'
then
echo shar: will not over-write existing file "'sources/array.c'"
else
cat << \SHAR_EOF > 'sources/array.c'
/*
Little Smalltalk
Array creation
timothy a. budd 10/84
builds a new instance of class array.
called mostly by the driver to construct array constants.
*/
/*
The source code for the Little Smalltalk System may be freely
copied provided that the source of all files is acknowledged
and that this condition is copied with each file.
The Little Smalltalk System is distributed without responsibility
for the performance of the program and without any guarantee of
maintenance.
All questions concerning Little Smalltalk should be addressed to:
Professor Tim Budd
Department of Computer Science
The University of Arizona
Tucson, Arizona
85721
USA
*/
# include <stdio.h>
# include "object.h"
class *Array = (class *) 0;
class *ArrayedCollection = (class *) 0;
extern object *o_nil, *o_empty, *o_acollection;
extern int started; /* gets set after reading std prelude */
/* new_iarray - internal form of new array */
object *new_iarray(size)
int size;
{ object *new;
if (size < 0) cant_happen(2);
new = new_obj(Array, size, 0);
if (! started) {
sassign(new->super_obj, o_acollection);
}
else if (ArrayedCollection)
sassign(new->super_obj, new_inst(ArrayedCollection));
return(new);
}
/* new_array - create a new array */
object *new_array(size, initial)
int size, initial;
{ int i;
object *new;
if (size == 0) return(o_empty);
new = new_iarray(size);
if (initial) {
for (i = 0; i < size; i++)
sassign(new->inst_var[ i ], o_nil);
}
return(new);
}
SHAR_EOF
if test 1500 -ne "`wc -c < 'sources/array.c'`"
then
echo shar: error transmitting "'sources/array.c'" '(should have been 1500 characters)'
fi
fi # end of overwriting check
if test -f 'sources/block.c'
then
echo shar: will not over-write existing file "'sources/block.c'"
else
cat << \SHAR_EOF > 'sources/block.c'
/*
Little Smalltalk
block creation and block return
timothy a. budd, 10/84
*/
/*
The source code for the Little Smalltalk System may be freely
copied provided that the source of all files is acknowledged
and that this condition is copied with each file.
The Little Smalltalk System is distributed without responsibility
for the performance of the program and without any guarantee of
maintenance.
All questions concerning Little Smalltalk should be addressed to:
Professor Tim Budd
Department of Computer Science
The University of Arizona
Tucson, Arizona
85721
USA
*/
# include <stdio.h>
# include "object.h"
# include "drive.h"
# include "interp.h"
# include "block.h"
# include "string.h"
# include "primitive.h"
# include "process.h"
extern object *o_object; /* value of generic object */
static mstruct *fr_block = 0; /* free list of unused blocks */
int ca_block = 0; /* count block allocations */
/* cpyInterpreter - make a new copy of an existing interpreter */
static interpreter *cpyInterpreter(anInterpreter)
interpreter *anInterpreter;
{ interpreter *new;
new = cr_interpreter((interpreter *) 0,
anInterpreter->receiver,
anInterpreter->literals,
anInterpreter->bytecodes,
anInterpreter->context);
if (anInterpreter->creator)
new->creator = anInterpreter->creator;
else
new->creator = anInterpreter;
new->currentbyte = anInterpreter->currentbyte;
return(new);
}
/* new_block - create a new instance of class Block */
object *new_block(anInterpreter, argcount, arglocation)
interpreter *anInterpreter;
int argcount, arglocation;
{ block *new;
if (fr_block) {
new = (block *) fr_block;
fr_block = fr_block->mlink;
}
else {
new = structalloc(block);
ca_block++;
}
new->b_ref_count = 0;
new->b_size = BLOCKSIZE;
sassign(new->b_interpreter, cpyInterpreter(anInterpreter));
new->b_numargs = argcount;
new->b_arglocation = arglocation;
return((object *) new);
}
/* free_block - return an unused block to the block free list */
free_block(b)
block *b;
{
if (! is_block(b))
cant_happen(8);
obj_dec((object *)(b->b_interpreter));
((mstruct *) b)->mlink = fr_block;
fr_block = (mstruct *) b;
}
/* block_execute - queue a block interpreter for execution */
interpreter *block_execute(sender, aBlock, numargs, args)
interpreter *sender;
block *aBlock;
int numargs;
object **args;
{ interpreter *newInt;
object *tempobj;
if (! is_block(aBlock)) cant_happen(11);
if (numargs != aBlock->b_numargs) {
sassign(tempobj,
new_str("wrong number of arguments for block"));
primitive(ERRPRINT, 1, &tempobj);
obj_dec(tempobj);
if (sender) {
push_object(sender, o_nil);
}
return(sender); /* not sure about this ..... */
}
/* we copy the interpreter so as to not destroy the original and to
avoid memory pointer cycles */
newInt = cpyInterpreter(aBlock->b_interpreter);
if (sender)
assign(newInt->sender, sender);
if (numargs)
copy_arguments(newInt, aBlock->b_arglocation,
numargs, args);
return(newInt);
}
/* block_return - return an object from the context in which a block was
created */
block_return(blockInterpreter, anObject)
interpreter *blockInterpreter;
object *anObject;
{ interpreter *backchain, *parent;
interpreter *creatorblock;
creatorblock = blockInterpreter->creator;
for (backchain = blockInterpreter->sender; backchain;
backchain = backchain->sender) {
if (! is_interpreter(backchain)) break;
if (backchain == creatorblock) {
/* found creating context, back up one more */
parent = backchain->sender;
if (parent) {
if (! is_driver(parent))
push_object(parent, anObject);
link_to_process(parent);
}
else {
terminate_process(runningProcess);
}
return;
}
}
/* no block found, issue error message */
primitive(BLKRETERROR, 1, (object **) &blockInterpreter);
parent = blockInterpreter->sender;
if (parent) {
if (! is_driver(parent))
push_object(parent, anObject);
link_to_process(parent);
}
else {
terminate_process(runningProcess);
}
}
SHAR_EOF
if test 4045 -ne "`wc -c < 'sources/block.c'`"
then
echo shar: error transmitting "'sources/block.c'" '(should have been 4045 characters)'
fi
fi # end of overwriting check
if test -f 'sources/block.h'
then
echo shar: will not over-write existing file "'sources/block.h'"
else
cat << \SHAR_EOF > 'sources/block.h'
/*
Little Smalltalk
block definitions
timothy a. budd, 10/84
*/
/*
for blocks
b_size = BLOCKSIZE
b_interpreter is an instance of interpreter that will
actually execute the bytecodes for the block.
b_numargs and b_arglocation are the number of arguments and
the starting argument location in the context array.
*/
struct block_struct {
int b_ref_count;
int b_size;
interpreter *b_interpreter;
int b_numargs;
int b_arglocation;
} ;
typedef struct block_struct block;
extern object *new_block();
extern interpreter *block_execute();
SHAR_EOF
if test 562 -ne "`wc -c < 'sources/block.h'`"
then
echo shar: error transmitting "'sources/block.h'" '(should have been 562 characters)'
fi
fi # end of overwriting check
if test -f 'sources/byte.c'
then
echo shar: will not over-write existing file "'sources/byte.c'"
else
cat << \SHAR_EOF > 'sources/byte.c'
/*
Little Smalltalk
bytearray manipulation.
bytearrays are used almost entirely for storing bytecodes.
timothy a. budd, 11/84
*/
/*
The source code for the Little Smalltalk System may be freely
copied provided that the source of all files is acknowledged
and that this condition is copied with each file.
The Little Smalltalk System is distributed without responsibility
for the performance of the program and without any guarantee of
maintenance.
All questions concerning Little Smalltalk should be addressed to:
Professor Tim Budd
Department of Computer Science
The University of Arizona
Tucson, Arizona
85721
USA
*/
# include <stdio.h>
# include "object.h"
# include "byte.h"
/*
bytearrays of less than MAXBSAVE are kept on a free list
*/
static mstruct *fr_bytearray[MAXBSAVE]; /* better be initialized to zero ! */
/*
in order to avoid a large number of small mallocs, a table is used
for the first new bytearrays. After the table becomes full,
malloc is used to get more space.
table should be large enough for the standard prelude, at least
*/
static uchar btable[MAXBTABSIZE];
int btabletop = 0;
/*
for the same reason, a number of bytearray bases are statically
allocated and kept on a free list
*/
int ca_barray = 0;
static mstruct *fr_bybase = 0;
static bytearray by_init[MAXBYINIT];
byte_init()
{ int i;
bytearray *p;
mstruct *new;
p = by_init;
for (i = 0; i < MAXBYINIT; i++) {
new = (mstruct *) p;
new->mlink = fr_bybase;
fr_bybase = new;
p++;
}
}
object *new_bytearray(values, size)
uchar *values;
int size;
{ bytearray *new;
uchar *p, *q;
if (size < MAXBSAVE && fr_bytearray[size]) {
new = (bytearray *) fr_bytearray[size];
fr_bytearray[size] = fr_bytearray[size]->mlink;
}
else {
if (fr_bybase) {
new = (bytearray *) fr_bybase;
fr_bybase = fr_bybase->mlink;
}
else {
new = structalloc(bytearray);
ca_barray++;
}
if ((btabletop + size) < MAXBTABSIZE) {
new->a_bytes = &btable[btabletop];
btabletop += size;
}
else {
new->a_bytes = (uchar *) o_alloc((unsigned) size);
}
}
new->a_ref_count = 0;
new->a_size = BYTEARRAYSIZE;
new->a_bsize = size;
for (p = new->a_bytes, q = values; size; size--) {
*p++ = *q++;
}
return((object *) new);
}
free_bytearray(obj)
bytearray *obj;
{ int size;
if (! is_bytearray(obj))
cant_happen(8);
size = obj->a_bsize;
if (size < MAXBSAVE) {
((mstruct *) obj)->mlink = fr_bytearray[size];
fr_bytearray[size] = ((mstruct *) obj);
}
}
SHAR_EOF
if test 2517 -ne "`wc -c < 'sources/byte.c'`"
then
echo shar: error transmitting "'sources/byte.c'" '(should have been 2517 characters)'
fi
fi # end of overwriting check
if test -f 'sources/byte.h'
then
echo shar: will not over-write existing file "'sources/byte.h'"
else
cat << \SHAR_EOF > 'sources/byte.h'
/*
Little Smalltalk
Bytearray definitions
*/
struct byte_struct {
int a_ref_count;
int a_size;
int a_bsize;
uchar *a_bytes;
} ;
typedef struct byte_struct bytearray;
# define byte_value(x) (((bytearray *)(x))->a_bytes)
/*
bytearrays of size less than MAXBSAVE are kept on a free list
*/
# define MAXBSAVE 50
/*
in order to avoid a large number of small mallocs, especially
while reading the standard prelude, a fixed area of MAXBTABSIZE is
allocated and used for bytecodes until it is full. Thereafter
bytecodes are allocated using malloc. This area should be large
enough to hold at least all the bytecodes for the standard prelude.
*/
# define MAXBTABSIZE 5500
/*
for the same reason, a number of bytearrays structs are statically
allocated and placed on a free list
*/
# define MAXBYINIT 400
extern object *new_bytearray();
SHAR_EOF
if test 855 -ne "`wc -c < 'sources/byte.h'`"
then
echo shar: error transmitting "'sources/byte.h'" '(should have been 855 characters)'
fi
fi # end of overwriting check
if test -f 'sources/class.c'
then
echo shar: will not over-write existing file "'sources/class.c'"
else
cat << \SHAR_EOF > 'sources/class.c'
/*
Little Smalltalk
class instance creation and deletion
timothy a. budd 10/84
*/
/*
The source code for the Little Smalltalk System may be freely
copied provided that the source of all files is acknowledged
and that this condition is copied with each file.
The Little Smalltalk System is distributed without responsibility
for the performance of the program and without any guarantee of
maintenance.
All questions concerning Little Smalltalk should be addressed to:
Professor Tim Budd
Department of Computer Science
The University of Arizona
Tucson, Arizona
85721
USA
*/
# include <stdio.h>
# include "object.h"
# include "file.h"
# include "number.h"
# include "symbol.h"
# include "string.h"
# include "primitive.h"
# define streq(x,y) (strcmp(x,y) == 0)
extern class *Array, *ArrayedCollection;
extern object *o_object, *o_empty, *o_number, *o_magnitude;
extern object *o_smalltalk, *o_acollection;
static mstruct *fr_class = 0;
int ca_class = 0; /* count class allocations */
# define CLASSINITMAX 30
static class cl_table[CLASSINITMAX];
class_init()
{ class *p;
mstruct *new;
int i;
for (p = cl_table, i = 0; i < CLASSINITMAX; i++, p++) {
new = (mstruct *) p;
new->mlink = fr_class;
fr_class = new;
}
}
class *new_class()
{ class *new;
if (fr_class) {
new = (class *) fr_class;
fr_class = fr_class->mlink;
}
else {
new = structalloc(class);
ca_class++;
}
new->c_ref_count = 0;
new->c_size = CLASSSIZE;
sassign(new->file_name, o_nil);
sassign(new->class_name, o_nil);
new->super_class = (object *) 0;
sassign(new->c_inst_vars, o_nil);
new->context_size = 0;
sassign(new->message_names, o_nil);
sassign(new->methods, o_nil);
return(new);
}
class *mk_class(classname, args)
char *classname;
object **args;
{ class *new;
object *new_iarray();
new = new_class();
assign(new->class_name, args[0]);
if (! streq(classname, "Object"))
sassign(new->super_class, args[1]);
assign(new->file_name, args[2]);
assign(new->c_inst_vars, args[3]);
assign(new->message_names, args[4]);
assign(new->methods, args[5]);
new->context_size = int_value(args[6]);
new->stack_max = int_value(args[7]);
if (streq(classname, "Array")) {
assign(Array, new);
assign(o_empty, new_iarray(0));
}
else if (streq(classname, "ArrayedCollection")) {
assign(ArrayedCollection, new);
assign(o_acollection, new_inst(new));
assign(o_empty, new_iarray(0));
}
else if (streq(classname, "False"))
assign(o_false, new_inst(new))
else if (streq(classname, "Magnitude"))
assign(o_magnitude, new_inst(new))
else if (streq(classname, "Number"))
assign(o_number, new_inst(new))
else if (streq(classname, "Object"))
assign(o_object, new_inst(new))
else if (streq(classname, "Smalltalk"))
assign(o_smalltalk, new_inst(new))
else if (streq(classname, "True"))
assign(o_true, new_inst(new))
else if (streq(classname, "UndefinedObject"))
assign(o_nil, new_inst(new))
return(new);
}
/* new_sinst - new instance with explicit super object */
object *new_sinst(aclass, super)
class *aclass;
object *super;
{ object *new;
char *classname, buffer[80];
if (! is_class(aclass))
cant_happen(4);
classname = symbol_value(aclass->class_name);
if ( streq(classname, "Block") ||
streq(classname, "Char") ||
streq(classname, "Class") ||
streq(classname, "Float") ||
streq(classname, "Integer") ||
streq(classname, "Process") ||
streq(classname, "Symbol") ) {
sprintf(buffer,"%s: does not respond to new", classname);
sassign(new, new_str(buffer));
primitive(ERRPRINT, 1, &new);
obj_dec(new);
if (super) /* get rid of unwanted object */
{obj_inc((object *) super);
obj_dec((object *) super);}
new = o_nil;
}
else if (streq(classname, "File")) {
new = new_file();
if (super) /* get rid of unwanted object */
{obj_inc((object *) super);
obj_dec((object *) super);}
}
else if (streq(classname, "String")) {
new = new_str("");
if (super)
assign(((string *) new)->s_super_obj, super);
}
else {
new = new_obj(aclass, (aclass->c_inst_vars)->size, 1);
if (super)
sassign(new->super_obj, super);
}
return(new);
}
object *new_inst(aclass)
class *aclass;
{ object *super, *sp_class_name, *lookup_class();
class *super_class;
if (! is_class(aclass))
cant_happen(4);
if (aclass == o_object->class)
return(o_object);
super = (object *) 0;
sp_class_name = aclass->super_class;
if (sp_class_name && is_symbol(sp_class_name)) {
super_class = (class *)
lookup_class(symbol_value(sp_class_name));
if (super_class && is_class(super_class))
super = new_inst(super_class);
}
return(new_sinst(aclass, super));
}
free_class(c)
class *c;
{
if (! is_class(c))
cant_happen(8);
obj_dec(c->class_name);
if (c->super_class)
obj_dec((object *) c->super_class);
obj_dec(c->file_name);
obj_dec(c->c_inst_vars);
obj_dec(c->message_names);
obj_dec(c->methods);
((mstruct *) c )->mlink = fr_class;
fr_class = (mstruct *) c;
}
SHAR_EOF
if test 4976 -ne "`wc -c < 'sources/class.c'`"
then
echo shar: error transmitting "'sources/class.c'" '(should have been 4976 characters)'
fi
fi # end of overwriting check
if test -f 'sources/cldict.c'
then
echo shar: will not over-write existing file "'sources/cldict.c'"
else
cat << \SHAR_EOF > 'sources/cldict.c'
/*
Little Smalltalk
Internal class dictionary
timothy a. budd, 10/84
In order to facilitate lookup, classes are kept in an internal data
dictionary. Classes are inserted into this dictionary using a
primtitive, and are removed by either being overridden, or being
flushed at the end of execution.
*/
/*
The source code for the Little Smalltalk System may be freely
copied provided that the source of all files is acknowledged
and that this condition is copied with each file.
The Little Smalltalk System is distributed without responsibility
for the performance of the program and without any guarantee of
maintenance.
All questions concerning Little Smalltalk should be addressed to:
Professor Tim Budd
Department of Computer Science
The University of Arizona
Tucson, Arizona
85721
USA
*/
# include <stdio.h>
# include "object.h"
# include "number.h"
# include "symbol.h"
# include "primitive.h"
struct class_entry { /* structure for internal dictionary */
char *cl_name;
object *cl_description;
struct class_entry *cl_link;
};
static struct class_entry *class_dictionary = 0;
int ca_cdict = 0;
static mstruct *fr_cdict = 0; /* class dictionary free list */
# define CDICTINIT 30
static struct class_entry cdsinit[CDICTINIT];
/* cdic_init - initialize the internal class dictionary */
cdic_init() {
struct class_entry *p;
mstruct *new;
int i;
for (p = cdsinit, i = 0; i < CDICTINIT; i++, p++) {
new = (mstruct *) p;
new->mlink = fr_cdict;
fr_cdict = new;
}
}
/* enter_class - enter a class into the internal class dictionary */
enter_class(name, description)
char *name;
object *description;
{ struct class_entry *p;
for (p = class_dictionary; p; p = p->cl_link)
if (strcmp(name, p->cl_name) == 0) {
assign(p->cl_description, description);
return;
}
/* not found, make a new entry */
if (fr_cdict) {
p = (struct class_entry *) fr_cdict;
fr_cdict = fr_cdict->mlink;
}
else {
p = structalloc(struct class_entry);
ca_cdict++;
}
p->cl_name = name;
sassign(p->cl_description, description);
p->cl_link = class_dictionary;
class_dictionary = p;
}
/* lookup - take a name and find the associated class object */
object *lookup_class(name)
char *name;
{ struct class_entry *p;
for (p = class_dictionary; p; p = p->cl_link)
if (strcmp(name, p->cl_name) == 0)
return(p->cl_description);
return((object *) 0);
}
/* free_all_classes - flush all references for the class dictionary */
free_all_classes()
{ struct class_entry *p;
for (p = class_dictionary; p; p = p->cl_link) {
obj_dec(p->cl_description);
}
}
/* class_list - list all the subclasses of a class (recursively),
indenting by a specified number of tab stops */
class_list(c, n)
class *c;
int n;
{ struct class_entry *p;
object *prs[2];
class *q;
char *name;
/* first print out this class name */
if (! is_symbol(c->class_name))
return;
sassign(prs[0], c->class_name);
name = symbol_value(c->class_name);
sassign(prs[1], new_int(n));
primitive(SYMPRINT, 2, prs);
obj_dec(prs[0]);
obj_dec(prs[1]);
/* now find all subclasses and print them out */
for (p = class_dictionary; p; p = p->cl_link) {
q = (class *) p->cl_description;
if ((is_symbol(q->super_class)) &&
(strcmp(name, symbol_value(q->super_class)) == 0) )
class_list(q, n+1);
}
}
SHAR_EOF
if test 3326 -ne "`wc -c < 'sources/cldict.c'`"
then
echo shar: error transmitting "'sources/cldict.c'" '(should have been 3326 characters)'
fi
fi # end of overwriting check
if test -f 'sources/courier.c'
then
echo shar: will not over-write existing file "'sources/courier.c'"
else
cat << \SHAR_EOF > 'sources/courier.c'
/*
Little Smalltalk
courier - message passing interface
timothy a. budd 10/84
*/
/*
The source code for the Little Smalltalk System may be freely
copied provided that the source of all files is acknowledged
and that this condition is copied with each file.
The Little Smalltalk System is distributed without responsibility
for the performance of the program and without any guarantee of
maintenance.
All questions concerning Little Smalltalk should be addressed to:
Professor Tim Budd
Department of Computer Science
The University of Arizona
Tucson, Arizona
85721
USA
*/
# include <stdio.h>
# include "object.h"
# include "interp.h"
# include "string.h"
# include "symbol.h"
# include "primitive.h"
# define streq(x,y) (strcmp(x,y) == 0)
/* send_mess - find the method needed to respond to a message, create the
proper context and interpreter for executing the method */
send_mess(sender, receiver, message, args, numargs)
interpreter *sender;
object *receiver, **args;
char *message;
int numargs;
{ object *robject, *method;
register object *message_array;
object *context, *fnd_super(), *fnd_class();
class *objclass;
interpreter *anInterpreter;
int i, maxc;
for (robject = receiver; robject; ) {
if (robject == (object *) 0) break;
if (is_bltin(robject))
objclass = (class *) fnd_class(robject);
else
objclass = robject->class;
if ((objclass == (class *) 0) || ! is_class(objclass)) break;
message_array = objclass->message_names;
for (i = 0; i < message_array->size; i++) {
if (symbol_value(message_array->inst_var[i]) ==
message) {
method = (objclass->methods)->inst_var[ i ];
goto do_cmd;
}
}
if (is_bltin(robject))
robject = fnd_super(robject);
else
robject = robject->super_obj;
}
/* if we reach this point then no method has been found matching message */
sassign(robject, new_obj((class *) 0, 2, 0));
sassign(robject->inst_var[0], receiver);
sassign(robject->inst_var[1], new_sym(message));
primitive(NORESPONDERROR, 2, &(robject->inst_var[0]));
obj_dec(robject);
/* generate a message passing trace */
backtrace(sender);
/* return nil by default */
if (is_interpreter(sender))
push_object(sender, o_nil);
link_to_process(sender);
goto clean_up;
/* do an interpreted method */
/* make a context and fill it in, make an interpeter and link it into
process queue */
do_cmd:
maxc = objclass->context_size;
sassign(context, new_obj((class *)0, maxc, 0));
for (i = 0; i <= numargs; i++)
sassign(context->inst_var[i], args[i]);
for ( ; i < maxc ; i++ )
sassign(context->inst_var[i], o_nil);
anInterpreter = cr_interpreter(sender, robject, method->inst_var[1],
method->inst_var[0], context);
link_to_process(anInterpreter);
obj_dec(context);
goto clean_up;
/* clean up after yourself */
clean_up:
return;
}
/* responds_to - see if a class responds to a message */
int responds_to(message, aClass)
char *message;
class *aClass;
{ object *message_names;
int i;
message_names = aClass->message_names;
for (i = 0; i < message_names->size; i++)
if (streq(symbol_value(message_names->inst_var[i]),
message))
return(1);
return(0);
}
/* backtrace - generate a backwards message passing trace */
static backtrace(current)
interpreter *current;
{
while (is_interpreter(current->sender) &&
! is_driver(current->sender)) {
fnd_message(current->receiver, current->bytecodes);
current = current->sender;
}
}
/* fnd_message - find the message associated with an interpreter */
static fnd_message(receiver, bytecodes)
object *receiver, *bytecodes;
{ int i;
class *oclass;
object *messar, *temp;
char buffer[100];
oclass = (class *) fnd_class(receiver);
messar = oclass->methods;
for (i = 0; i < messar->size; i++) {
if ((messar->inst_var[i])->inst_var[0] == bytecodes) {
sprintf(buffer,"%s: backtrace. message %s",
symbol_value(oclass->class_name),
symbol_value(
(oclass->message_names)->inst_var[i]));
sassign(temp, new_str(buffer));
primitive(ERRPRINT, 1, &temp);
obj_dec(temp);
return;
}
}
cant_happen(24);
}
/* prnt_messages - print all the messages a class responds to.
needed because the messages names array for some of the classes is
created before ArrayedCollection, and thus some do not respond to
do: */
prnt_messages(aClass)
class *aClass;
{ object *message_names;
int i;
message_names = aClass->message_names;
for (i = 0; i < message_names->size; i++)
primitive(SYMPRINT, 1, &message_names->inst_var[i]);
}
SHAR_EOF
if test 4517 -ne "`wc -c < 'sources/courier.c'`"
then
echo shar: error transmitting "'sources/courier.c'" '(should have been 4517 characters)'
fi
fi # end of overwriting check
if test -f 'sources/disclaim'
then
echo shar: will not over-write existing file "'sources/disclaim'"
else
cat << \SHAR_EOF > 'sources/disclaim'
/*
The source code for the Little Smalltalk System may be freely
copied provided that the source of all files is acknowledged
and that this condition is copied with each file.
The Little Smalltalk System is distributed without responsibility
for the performance of the program and without any guarantee of
maintenance.
All questions concerning Little Smalltalk should be addressed to:
Professor Tim Budd
Department of Computer Science
The University of Arizona
Tucson, Arizona
85721
USA
*/
SHAR_EOF
if test 512 -ne "`wc -c < 'sources/disclaim'`"
then
echo shar: error transmitting "'sources/disclaim'" '(should have been 512 characters)'
fi
fi # end of overwriting check
# End of shell archive
exit 0
Thread Navigation
This is a paginated view of messages in the thread with full content displayed inline.
Messages are displayed in chronological order, with the original post highlighted in green.
Use pagination controls to navigate through all messages in large threads.
Back to All Threads