DIRECTORY Scheme, BasicTime;

SchemeTimerImpl: CEDAR PROGRAM
IMPORTS Scheme, BasicTime
~ BEGIN OPEN Scheme;

TimerRep: TYPE ~ RECORD [pulses: BasicTime.Pulses];

MakeTimerPrim: PROC [Primitive, Any, Any, Any, ProperList] RETURNS [Any] ~ {
timer: REF TimerRep ~ NEW[TimerRep];
timer.pulses ¬ BasicTime.GetClockPulses[];
RETURN [timer]
};

TheTimer: PROC [a: Any] RETURNS [REF TimerRep] ~ {
WITH a SELECT FROM
t: REF TimerRep => RETURN [t];
ENDCASE => Complain[a, "not a timer"];
};

TimerPrim: PROC [self: Primitive, a, b, c: Any, rest: ProperList] RETURNS [Any ¬ unspecified] ~ {
t: REF TimerRep ~ TheTimer[a];
SELECT self.data FROM
$ref => {
now: BasicTime.Pulses ~ BasicTime.GetClockPulses[];
RETURN [MakeFixnum[BasicTime.PulsesToMicroseconds[now-t.pulses]]]
};
$set => {
t.pulses ¬ BasicTime.GetClockPulses[];
};
ENDCASE => ERROR;
};

TimerPredPrim: PROC [self: Primitive, a, b, c: Any, rest: ProperList] RETURNS [Any ¬ unspecified] ~ {
RETURN [WITH a SELECT FROM t: REF TimerRep => true ENDCASE => false];
};

Init: PROC [env: Environment] ~ {
DefinePrimitive[name: "make-timer", nArgs: 0, proc: MakeTimerPrim, doc: "Create a timer object", env: env, dotted: FALSE];
DefinePrimitive[name: "timer-start!", nArgs: 1, proc: TimerPrim, doc: "(timer) Start a Timer", env: env, dotted: FALSE, data: $set];
DefinePrimitive[name: "timer-ref", nArgs: 1, proc: TimerPrim, doc: "(timer) Get the number of microseconds since the timer start", env: env, dotted: FALSE, data: $ref];
DefinePrimitive[name: "timer?", nArgs: 1, proc: TimerPredPrim, doc: "test for a Timer", env: env, dotted: FALSE];
};

RegisterInit[Init];

END.
   Â  
SchemeTimerImpl.mesa
Copyright Ó 1988, 1991 by Xerox Corporation.  All rights reserved.
Michael Plass, August 24, 1988 10:23:39 am PDT

This is an example of several Scheme primitives implemented by one Cedar procedure.  This may help conserve scarce system resources, and often allows code sharing.  Since there are only a few cases here, we can use an atom as a key, but with many cases it would be better to use a REF to an enumerated type
Ê  •NewlineDelimiter
–(cedarcode) style™ codešœ™Kšœ
Ïeœ7™BK™.K™ —KšÏk	œ˜K˜ KšÐlnœž˜Kšžœ˜šœžœžœ˜K˜ šœ
žœžœ˜3K˜ —šÏnœžœ(žœ
˜LKšœžœžœ˜$K˜*Kšžœ˜Kšœ˜K˜ —š œžœ
žœžœ˜2šžœžœž˜Kšœžœžœ˜Kšžœ˜&—Kšœ˜K˜ —š 	œžœ3žœ˜aK™²Kšœžœ˜šžœž˜˜	Kšœ3˜3Kšžœ;˜AK˜—˜	K˜&K˜—Kšžœžœ˜—Kšœ˜K˜ —š œžœ3žœ˜eKšžœžœžœžœžœžœ˜EKšœ˜K˜ —š œžœ˜!K•StartOfExpansion7[name: ROPE, nArgs: NAT, dotted: BOOL, proc: PROC [...]šœsžœ˜zK–7[name: ROPE, nArgs: NAT, dotted: BOOL, proc: PROC [...]šœqžœ˜„K–7[name: ROPE, nArgs: NAT, dotted: BOOL, proc: PROC [...]šœ•žœ˜¨K–7[name: ROPE, nArgs: NAT, dotted: BOOL, proc: PROC [...]šœjžœ˜qKšœ˜K˜ —K˜—K˜ Kšžœ˜— …—    R  )  