home *** CD-ROM | disk | FTP | other *** search
/ Frozen Fish 2: PC / frozenfish_august_1995.bin / bbs / d07xx / d0764.lha / Gambit_Terp / OO-Scheme.YASOS < prev    next >
Text File  |  1992-11-21  |  33KB  |  1,033 lines
  1. FILE        "OO-Scheme.YASOS"
  2. IMPLEMENTS    Article on Object Oriented programming in Scheme.
  3. AUTHOR        Ken Dickey
  4. DATE        1992 June 1
  5. LAST UPDATED    1992 October 5 -- for distribution
  6. NOTES:        Published in AI Expert, vol 7, # 10, October 1992.
  7. ;---------------------------------------------------------------------
  8.  
  9.  
  10.          Scheming  with  Objects
  11.  
  12.  
  13. There is a saying--attributed to Norman Adams--that "Objects are a
  14. poor man's closures." In this article we discuss what closures are and
  15. how objects and closures are related, show code samples to make these
  16. abstract ideas concrete, and implement a Scheme Object System which
  17. solves the problems we uncover along the way. 
  18.  
  19.  
  20.  
  21. THE CLASSICAL OBJECT MODEL
  22.  
  23.  
  24. Before discussing object oriented programming in Scheme, it pays to
  25. take a look at the classical model so that we have something to
  26. compare with and in order to clarify some of the terminology.  One of
  27. the problems that the OO movement created for itself was the use of
  28. new terms to get away from older concepts and the confusion this has
  29. caused.  So before going further I would like to give some of my own
  30. definitions and a simple operational model.  The model is not strictly
  31. correct as most compiled systems use numerous short cuts and special
  32. optimization tricks, but it is close enough for most practical
  33. purposes and has been used to implement OO programming in imperative
  34. languages. 
  35.  
  36. An object "instance" consists of local (encapsulated) state and a
  37. reference to shared code which operates on its state.  The easy way to
  38. think of this is as a C struct or Pascal record which has one field
  39. reserved for a pointer to its shared code environment and other slots
  40. for its instance variables.  Each procedure in this shared environment
  41. is called a "method." A "class" is code which is can generate
  42. instances (new records) by initializing their fields, including a
  43. pointer to the instance's shared method environment.  The environment
  44. just maps method names to their values (their code).  Each method is a
  45. procedure which takes the record it is operating on as its first,
  46. sometimes hidden, argument.  The first argument is called the
  47. "reciever" and typically aliased to the name "self" within the
  48. procedure's code. 
  49.  
  50. In order to make code management easy, object oriented systems such as
  51. Actor or Smalltalk wish to deal with code as objects and the way this
  52. is done is by making each class an object instance as well.  In order
  53. to manipulate the class's code, however a "meta-class" is typically
  54. defined and in some cases a meta-meta...  Well, you get the idea.
  55. Many people have spent a great deal of time in theories of how to
  56. "ground" such systems without infinite recursion.  To confuse things
  57. further, many object systems have an object named "object" and a class
  58. object named "class"--so that the class of the "class" object is
  59. `class'. 
  60.  
  61. By making every data object an instance of the OO system, uniformity
  62. demands that numbers are added, e.g. 1 + 2 by "sending the message" +
  63. to the object 1 with the argument 2.  This has the advantage that + is
  64. polymorphic--it can be applied to any data object.  Unfortunately,
  65. polymorphism also makes optimization hard in that the compiler can no
  66. longer make assumptions about + and may not be able to do constant
  67. folding or inlining. 
  68.  
  69. The set of methods an object responds to is called a "protocol".
  70. Another way of saying this is that the functions or operations that
  71. are invokeable on an object make up its interface.  More than one
  72. class of object may respond to the same protocol--i.e. many different
  73. types of objects have the same operation names available. 
  74.  
  75.  
  76.  
  77.  
  78. OBJECT BASED MESSAGE PASSING
  79.  
  80.  
  81. So how can this "message passing" be implemented with lexical
  82. closures?  And what are these closure things anyway? 
  83.  
  84. References within a function to variables outside of the local
  85. scope--free references--are resolved by looking them up in the
  86. environment in which the function finds itself.  When a language is
  87. lexically scoped, you see the shape of the environment when you
  88. read--lex--the code.  In Scheme, when a function is created it
  89. remembers the environment in which it was created.  Free names are
  90. looked up in that environment, so the environment is said to be
  91. "closed over" when the function is created.  Hence the term "closure."
  92.  
  93.  
  94. An example may help here:
  95.  
  96. (define (CURRIED-ADD x) (lambda (y) (+ x y))
  97.  
  98. (define ADD8 (curried-add 8))
  99.  
  100. (add8 3)    -> 11
  101.  
  102.  
  103.  
  104. When add8 is applied to its argument, we are doing ((lambda (y) (+ x y)) 3)
  105.  
  106. The function add8 remembers that X has the value 8.  It gets the value
  107. Y when it is applied to 3.  It finds that + is the addition function.
  108. So (add8 3) evaluates to 11. 
  109.  
  110. (define ADD5 (curried-add 5)) makes a new function which shares the
  111. curried-add code (lambda (y) (+ x y)), but remembers that in its
  112. closed over environment, X has the value 5. 
  113.  
  114. Now that we have a way to create data objects, closures, which share
  115. code but have different data, we just need a "dispatching function" to
  116. which we can pass the symbols we will use for messages:
  117.  
  118. (define (MAKE-POINT the-x the-y)
  119.   (lambda (message)
  120.      (case message
  121.         ((x)  (lambda () the-x)) ;; return a function which returns the answer
  122.         ((y)  (lambda () the-y))
  123.         ((set-x!) 
  124.              (lambda (new-value)
  125.                      (set! the-x new-value)  ;; do the assignment
  126.                       the-x))                ;; return the new value
  127.         ((set-y!) 
  128.              (lambda (new-value)
  129.                      (set! the-y new-value)
  130.                       the-y))
  131.        (else (error "POINT: Unknown message ->" message))
  132. ) )  )
  133.  
  134.  
  135.  
  136. (define p1 (make-point 132 75))
  137.  
  138. (define p2 (make-point 132 57))
  139.  
  140. ((p1 'x))        -> 132
  141.  
  142. ((p1 'set-x!) 5)    -> 5
  143.  
  144.  
  145. We can even change the message passign style to function calling style:
  146.  
  147. (define (x obj) ((obj 'x))
  148.  
  149. (define (set-x! obj new-val) ((obj 'set-x!) new-val))
  150.  
  151.  
  152. (set-x! p1 12)     -> 12 
  153.  
  154. (x p1)         -> 12
  155.  
  156. (x p2)        -> 132    ;; p1 and p2 share code but have different local data
  157.  
  158.  
  159. Using Scheme's lexical scoping, we can also define make-point as:
  160.  
  161. (define (MAKE-POINT the-x the-y)
  162.  
  163.   (define (get-x) the-x)    ;; a "method"
  164.  
  165.   (define (get-y) the-y)
  166.  
  167.   (define (set-x! new-x) 
  168.      (set! the-x new-x)
  169.      the-x)
  170.  
  171.   (define (set-y! new-y) 
  172.      (set! the-y new-y)
  173.      the-y)
  174.  
  175.   (define (self message)
  176.      (case message
  177.         ((x)         get-x) ;; return the local function
  178.         ((y)        get-y)
  179.         ((set-x!) set-x!)
  180.         ((set-y!) set-y!)
  181.         (else (error "POINT: Unknown message ->" message))))
  182.  
  183.   self     ;; the return value of make-point is the dispatch function
  184. )
  185.  
  186.  
  187.  
  188.  
  189. ADDING INHERITANCE
  190.  
  191.  
  192. "Inheritance" means that one object may be specialized by adding to
  193. and/or shadowing another's behavior.  It is said that "object based"
  194. programming together with inheritance is "object oriented" programming.
  195. How can we add inheritance to the above picture?  By delegating to
  196. another object! 
  197.  
  198.  
  199. (define (MAKE-POINT-3D a b the-z)
  200.   (let ( (point (make-point a b)) )
  201.  
  202.    (define (get-z) the-z)
  203.  
  204.    (define (set-z! new-value)
  205.       (set! the-z new-value)
  206.       the-z)
  207.  
  208.    (define (self message)
  209.      (case message
  210.          ((z)         get-z)
  211.          ((set-z!)     set-z!)
  212.          (else (point message))))
  213.  
  214.   self
  215. )
  216.  
  217. (define p3 (make-point-3d 12 34 217))
  218.  
  219. (x p3)        -> 12
  220.  
  221. (z p3)        -> 217
  222.  
  223. (set-x! p3 12)    -> 12
  224.  
  225. (set-x! p2 12)    -> 12
  226.  
  227. (set-z! p3 14)    -> 14
  228.  
  229. Note that in this style, we are not required to have a single distinguished
  230. base object, "object"--although we may do so if we wish.
  231.  
  232.  
  233.  
  234.  
  235. WHAT IS WRONG WITH THE ABOVE PICTURE ?
  236.  
  237.  
  238. While the direct strategy above is perfectly adequate for OO
  239. programming, there are a couple of rough spots.  For example, how can
  240. we tell which functions are points and which are not?  We can define a
  241. POINT?  predicate, but not all Scheme data objects will take a 'point?
  242. message.  Most will generate error messages, but some will just "do
  243. the wrong thing."
  244.  
  245. (define (POINT? obj) (and (procedure? obj) (obj 'point?)))
  246.  
  247. (point? list)     -> (point?)  ;; a list with the symbol 'point?
  248.  
  249. We want a system in which all objects participate and in which we can
  250. mix styles.  Building dispatch functions is repetitive and can
  251. certainly be automated--and let's throw in multiple inheritance while
  252. we are at it.  Also, it is generally a good design principle to
  253. separate interface from implementation, so we will. 
  254.  
  255.  
  256.  
  257. ONE SET OF SOLUTIONS
  258.  
  259. The following is one of a large number of possible implementations.
  260. Most Scheme programmers I know have written at least one object system
  261. and some have written several.  Let's first look at the interface, then
  262. how it is used, then how it was implemented.
  263.  
  264. In order to know what data objects are "instances", we have a
  265. predicate, INSTANCE?, which takes a single argument and answers #t or
  266. #f.  
  267.  
  268. For each kind of object is also useful to have a predicate, so we
  269. define a predicate maker: (DEFINE-PREDICATE <opname?>) which by default
  270. answers #f.  
  271.  
  272. To define operations which operate on any data, we need a default
  273. behavior for data objects which don't handle the operation:
  274. (DEFINE-OPERATION (opname self arg ...) default-body).  If
  275. we don't supply a default-behavior, the default default-behavior
  276. is to generate an error.
  277.  
  278. We certainly need to return values which are instances of our object
  279. system: (OBJECT operation... ), where an operation has the form:
  280. ((opname self arg ...) body).  There is also a LET-like form for
  281. multiple inheritance:
  282.    (OBJECT-WITH-ANCESTORS ( (ancestor1 init1) ...) 
  283.     operation ...).
  284. In the case of multiple inherited operations with the same identity,
  285. the operation used is the one found in the first ancestor in the
  286. ancestor list.
  287.  
  288. And finally, there is the "send to super" problem, where we want to
  289. operate as an ancestor, but maintain our own self identity {more on
  290. this below}:  (OPERATE-AS component operation composite arg ...).
  291.  
  292. Note that in this system, code which creates instances is just code, so
  293. there there is no need to define "classes" and no meta-<anything>!
  294.  
  295.  
  296. EXAMPLES
  297.  
  298. O.K., let's see how this fits together.  First, another look at
  299. points. ***See LISTING: Points revisited (below)***
  300.  
  301. (define P2 (make-point 123 32131))
  302. (define P3 (make-point-3d 32 121 3232))
  303. (size "a string")    -> 8
  304. (size p2)        -> 2
  305. (size p3)        -> 3
  306. (point? p2)        -> #t
  307. (point? p3)        -> #t
  308. (point? "a string")    -> #f
  309. (x p2)            -> 123
  310. (x p3)            -> 32
  311. (x "a string")        -> ERROR: Operation not handled: x "a string"
  312. (print p2 #t)        #<point: 123 32131>
  313. (print p3 #t)       #<3D-point: 32 121 3232>
  314. (print "a string" #t)     "a string"
  315.  
  316. Things to notice...
  317.   Interface is separate from implementation
  318.   All objects participate
  319.   Inheritance is simplified
  320.   Print unifies treatment of objects--each decides how it is to be displayed
  321.   Default behaviors are useful
  322.   
  323.  
  324. Now lets look at a more interesting example, a simplified savings
  325. account with history and passwords.
  326.  
  327.  
  328. *** See LISTING: Bank accounts (below) ***
  329.  
  330.  
  331. (define FRED  (make-person "Fred" 19 "573-19-4279" #xFadeCafe))
  332. (define SALLY
  333.   (make-account "Sally" 26 "629-26-9742" #xFeedBabe 263 bank-password))
  334.  
  335. (print fred #t)        #<Person: Fred age: 19>
  336. (print sally #t)    #<Bank-Customer Sally>
  337. (person? sally)        -> #t
  338. (bank-account? sally)    -> #t
  339. (ssn fred  #xFadeCafe)    -> "573-19-4279"
  340. (ssn sally #xFeedBabe)    -> "629-26-9742"
  341. (add sally 130)     New balance: $393
  342. (add sally 55)        New balance: $448
  343.  
  344. ; the bank can act in Sally's behalf
  345. (get-account-history sally bank-password)          --> (448 393 263)
  346. (withdraw sally 100 (get-pin sally bank-password))    New balance: $348
  347. (get-account-history sally bank-password)              --> (348 448 393 263)
  348.  
  349. ;; Fred forgets
  350. (ssn fred 'bogus)    Bad password: bogus    ;; Fred gets another chance
  351.  
  352. ;; Sally forgets
  353. (ssn sally 'bogus)    CALL THE POLICE!!    ;; A more serious result..
  354.  
  355. Now we see the reason we need OPERATE-AS.  The when the bank-account
  356. object delegates the SSN operation to its ancestor, person, SELF is
  357. bound to the bank-account object--not the person object.  This means
  358. that while the code for SSN is inherited from person, the BAD-PASSWORD
  359. operation of the bank-account is used.
  360.  
  361. This is an important behavior to have in an object system.  If there
  362. were no OPERATE-AS, code would have to be duplicated in order to
  363. implement the stricter form of BAD-PASSWORD.  With OPERATE-AS, we can
  364. safely share code while keeping operations localized within the
  365. inheritance hierarchy.
  366.  
  367.  
  368.  
  369. OUR IMPLEMENTATION
  370.  
  371. Given the sophisticated behavior of our object system, the
  372. implementation is surprisingly small.
  373.  
  374. *** See LISTING: yasos (below) ***
  375.  
  376. Unlike some other languages, Scheme does not have a standard way of
  377. defining opaque types.  In order to distinguish data objects which are
  378. instances of our object system, we just uniquely tag a closure.  As we
  379. are only introducing one new datatype it is not much work to hide this
  380. by rewriting Scheme's WRITE and DISPLAY routines. 
  381.  
  382. In order to allow lexical scoping of objects and operations, the
  383. values of operations, rather than their names, are used in the
  384. dispatch functions created for objects.  Those of you who have used
  385. languages such as Smalltalk or Actor may have been bitten by the
  386. inadvertant name collisions in the single, global environment.
  387.  
  388. Note that there are no global tables.  A general rule of thumb is that
  389. for less than 100 elements, linear search beats hashing.  While we can
  390. speed up operation dispatch by some simple caching, the general
  391. performance for this system will be pretty good up through moderately
  392. large systems.  Also, we can optimize the implementation with no
  393. change to the interface.  If our systems start getting too slow, its
  394. time to smarten the compiler.
  395.  
  396.  
  397.  
  398. HOW THIS COMPARES TO THE CLASSICAL MODEL
  399.  
  400. It is time to compare this implementation to the model given at the
  401. beginning of this article.
  402.  
  403. One thing you may notice right away is the power of closures.  The
  404. object system is small and simpler than the class model.  There are no
  405. grounding problems.  No "Meta".  I find it interesting that
  406. Whitewater's Actor 4.0 implements code sharing between classes (which
  407. they call multiple inheritance) in an attempt to get more of the
  408. benefits that closures provide directly.
  409.  
  410. The Scheme solution is also more general.  It keeps lexical scoping,
  411. and one can freely mix OO with functional & imperative styles.
  412.  
  413. Programming Environment work still has to be done for code management
  414. & debugging (e.g. doing an object inspector), but OO helps here just
  415. as in other OO systems.
  416.  
  417. Separating the interface from the implementation is a better software
  418. engineering solution than the classical model.  We can define our
  419. "protocols" independently of their implementation.  This helps us hide
  420. our implementation.  One might think that object oriented programming
  421. in general would solve the problems here, but this has not been the
  422. case because people still use inheritance to share code rather than
  423. just to share abstractions.  An example of this is the complex
  424. behavior of Smalltalk dictionaries because they inherit the
  425. implementation of Sets.  While code sharing is a benefit of OO it is
  426. still considered bad form when your code breaks because of a change in
  427. the implementation of an inherited abstraction.
  428.  
  429. Finally, I would like to point out that one can implement other OO
  430. models directly in Scheme, including smaller, simpler ones!  You can
  431. also implement the classical model (e.g. see D. Friedman, M. Wand, &
  432. C. Haynes: _Essentials of Programming Languages_, McGraw Hill, 1992). 
  433.  
  434. Remember, your programming language should be part of the solution, not
  435. part of your problems.  Scheme for success!
  436.  
  437.  
  438. ---------------------------EndOfArticle-------------------------------
  439.  
  440. ***************************
  441. * LISTING: Points revisited
  442. ***************************
  443.  
  444. ;;---------------------
  445. ;; general operations
  446. ;;---------------------
  447.  
  448. (define-operation (PRINT obj port) 
  449.   (format port  ;; *** see LISTING: format ***
  450.           ;; if an instance does not have a PRINT operation..
  451.           (if (instance? obj) "#<INSTANCE>" "~s") 
  452.           obj
  453. ) )
  454.  
  455. (define-operation (SIZE obj)
  456.   ;; default behavior
  457.   (cond   
  458.     ((vector? obj) (vector-length obj))
  459.     ((list?   obj) (length obj))
  460.     ((pair?   obj) 2)
  461.     ((string? obj) (string-length obj))
  462.     ((char?   obj) 1)
  463.     (else 
  464.       (error "Operation not supported: size" obj))
  465. ) )
  466.  
  467.  
  468. ;;----------------
  469. ;; point interface
  470. ;;----------------
  471.  
  472. (define-predicate POINT?)  ;; answers #f (false) by default
  473. (define-operation (X obj))
  474. (define-operation (Y obj))
  475. (define-operation (SET-X! obj new-x))
  476. (define-operation (SET-Y! obj new-y))
  477.  
  478.  
  479. ;;---------------------
  480. ;; point implementation
  481. ;;---------------------
  482.  
  483. (define (MAKE-POINT the-x the-y)
  484.   (object
  485.      ((POINT? self) #t) ;; yes, this is a point object
  486.      ((X self) the-x)
  487.      ((Y self) the-y)
  488.      ((SET-X! self val)
  489.       (set! the-x val)
  490.       the-x)
  491.      ((SET-Y! self val)
  492.       (set! the-y val)
  493.       the-y)
  494.      ((SIZE self) 2)
  495.      ((PRINT self port)
  496.       (format port "#<point: ~a ~a>" (x self) (y self)))
  497. ) )
  498.  
  499. ;;-----------------------------
  500. ;; 3D point interface additions
  501. ;;-----------------------------
  502.  
  503. (define-operation (Z obj))
  504. (define-operation (SET-Z! obj new-z))
  505.  
  506.  
  507. ;;------------------------
  508. ;; 3D point implementation
  509. ;;------------------------
  510.  
  511. (define (MAKE-POINT-3D the-x the-y the-z)
  512.    (object-with-ancestors ( (a-point (make-point the-x the-y)) )
  513.       ((Z self) the-z)
  514.       ((SET-Z! self val) (set! the-z val) the-z)
  515.       ;; override inherited SIZE and PRINT operations
  516.       ((SIZE self) 3)
  517.       ((PRINT self port)
  518.        (format port "#<3D-point: ~a ~a ~a>" (x self) (y self) (z self)))
  519. )  )
  520.  
  521. ***------------------------------------------------------------
  522.  
  523. ***********************
  524. *LISTING: Bank accounts
  525. ***********************
  526.  
  527.  
  528. ;;-----------------
  529. ;; person interface
  530. ;;-----------------
  531.  
  532. (define-predicate PERSON?)
  533.  
  534. (define-operation (NAME obj))
  535. (define-operation (AGE obj))
  536. (define-operation (SET-AGE! obj new-age))
  537. (define-operation (SSN obj password)) ;; Social Security # is protected
  538. (define-operation (NEW-PASSWORD obj old-passwd new-passwd))
  539. (define-operation (BAD-PASSWORD obj bogus-passwd)
  540.   ;; assume internal (design) error
  541.   (error (format #f "Bad Password: ~s given to ~a~%" 
  542.                     bogus-passwd
  543.             (print obj #f)))
  544. )
  545.  
  546.  
  547. ;;----------------------
  548. ;; person implementation
  549. ;;----------------------
  550.  
  551. (define (MAKE-PERSON a-name an-age a-SSN the-password)
  552.   (object
  553.     ((PERSON? self) #t)
  554.     ((NAME self) a-name)
  555.     ((AGE self) an-age)
  556.     ((SET-AGE! self val) (set! an-age val) an-age)
  557.     ((SSN self password)
  558.      (if (equal? password the-password)
  559.          a-SSN
  560.      (bad-password self password))
  561.     )
  562.     ((NEW-PASSWORD obj old-passwd new-passwd)
  563.      (cond
  564.        ((equal? old-passwd the-password) (set! the-password new-passwd) self)
  565.        (else (bad-password self old-passwd))
  566.     ))
  567.     ((BAD-PASSWORD self bogus-passwd)
  568.      (format #t "Bad password: ~s~%" bogus-passwd))  ;; let user recover
  569.     ((PRINT self port)
  570.      (format port "#<Person: ~a age: ~a>" (name self) (age self)))
  571. ) )
  572.  
  573. ;;--------------------------------------------
  574. ;; account-history and bank-account interfaces
  575. ;;--------------------------------------------
  576.  
  577. (define-predicate BANK-ACCOUNT?)
  578.  
  579. (define-operation (CURRENT-BALANCE account pin))
  580. (define-operation (ADD obj amount))
  581. (define-operation (WITHDRAW obj amount pin))
  582. (define-operation (GET-PIN account master-password))
  583. (define-operation (GET-ACCOUNT-HISTORY account master-password))
  584.  
  585. ;;-------------------------------
  586. ;; account-history implementation
  587. ;;-------------------------------
  588. ;; put access to bank database and report generation here
  589.  
  590. (define (MAKE-ACCOUNT-HISTORY initial-balance a-PIN master-password)
  591.   ;; history is a simple list of balances -- no transaction times
  592.   (letrec ( (history (list initial-balance)) 
  593.             (balance (lambda () (car history))) ; balance is a function
  594.             (remember 
  595.               (lambda (datum) (set! history (cons datum history))))
  596.           )
  597.     (object
  598.       ((BANK-ACCOUNT? self) #t)
  599.       ((ADD self amount) ;; bank will accept money without a password
  600.        (remember (+ amount (balance)))
  601.        ;; print new balance
  602.        (format #t "New balance: $~a~%" (balance)) 
  603.       )
  604.       ((WITHDRAW self amount pin)
  605.        (cond
  606.           ((not (equal? pin a-pin)) (bad-password self pin))
  607.       ((< (- (balance) amount) 0)
  608.        (format #t 
  609.               "No overdraft~% Can't withdraw more than you have: $~a~%"
  610.           (balance))
  611.           )
  612.       (else
  613.         (remember (- (balance) amount))
  614.             (format #t "New balance: $~a~%" (balance)))
  615.       ))
  616.       ((CURRENT-BALANCE self password)
  617.        (if (or (eq? password master-password) (equal? password a-pin))
  618.            (format #t "Your Balance is $~a~%" (balance))
  619.        (bad-password self password)
  620.       )
  621.       ;; only bank has access to account history
  622.       ((GET-ACCOUNT-HISTORY account password) 
  623.        (if (eq? password master-password)
  624.            history
  625.        (bad-password self password)
  626.       ))
  627. ) ) )
  628.  
  629. ;;----------------------------
  630. ;; bank-account implementation
  631. ;;----------------------------
  632.  
  633. (define (MAKE-ACCOUNT a-name an-age a-SSN a-PIN initial-balance master-password)
  634.  
  635.   (object-with-ancestors 
  636.  
  637.      ( (customer (make-person a-name an-age a-SSN a-PIN))
  638.        (account  (make-account-history initial-balance a-PIN master-password))
  639.      )
  640.  
  641.     ((GET-PIN self password)
  642.      (if (eq? password master-password)
  643.      a-PIN
  644.      (bad-password self password)
  645.     ))
  646.     ((GET-ACCOUNT-HISTORY self password)
  647.      (operate-as account get-account-history self password)
  648.     )
  649.     ;; our bank is very conservative...
  650.     ((BAD-PASSWORD self bogus-passwd)
  651.      (format #t "~%CALL THE POLICE!!~%")  
  652.     )
  653.     ;; protect the customer as well
  654.     ((SSN self password) 
  655.      (operate-as customer SSN self password)
  656.     )
  657.     ((PRINT self port)
  658.      (format port "#<Bank-Customer ~a>" (name self)))
  659. ) )
  660.  
  661.  
  662.  
  663. ***----------------------------------------------------------------
  664.  
  665. ******************
  666. * LISTING: yasos *
  667. ******************
  668. ;; FILE        "oop.scm"
  669. ;; IMPLEMENTS    YASOS: Yet Another Scheme Object System
  670. ;; AUTHOR    Kenneth Dickey
  671. ;; DATE        1992 March 1
  672. ;; LAST UPDATED    1992 March 5
  673.  
  674. ;; REQUIRES    R4RS Syntax System
  675.  
  676. ;; NOTES: An object system for Scheme based on the paper by
  677. ;; Norman Adams and Jonathan Rees: "Object Oriented Programming in
  678. ;; Scheme", Proceedings of the 1988 ACM Conference on LISP and 
  679. ;; Functional Programming, July 1988 [ACM #552880].
  680.  
  681. ;;
  682. ;; INTERFACE:
  683. ;;
  684. ;; (DEFINE-OPERATION (opname self arg ...) default-body)
  685. ;;
  686. ;; (DEFINE-PREDICATE opname)
  687. ;;
  688. ;; (OBJECT ((name self arg ...) body) ... )
  689. ;;
  690. ;; (OBJECT-WITH-ANCESTORS ( (ancestor1 init1) ...) operation ...)
  691. ;;
  692. ;; in an operation {a.k.a. send-to-super}
  693. ;;   (OPERATE-AS component operation self arg ...)
  694. ;;
  695.  
  696.  
  697. ;; INSTANCES
  698.  
  699. ; (define-predicate instance?)
  700. ; (define (make-instance dispatcher)
  701. ;    (object
  702. ;     ((instance?  self) #t)
  703. ;       ((instance-dispatcher self) dispatcher)
  704. ; )  )
  705.  
  706. (define make-instance 'bogus)  ;; defined below
  707. (define instance?     'bogus)
  708. (define-syntax INSTANCE-DISPATCHER  ;; alias so compiler can inline for speed
  709.    (syntax-rules () ((instance-dispatcher inst) (cdr inst)))
  710. )
  711.  
  712. (let ( (instance-tag "instance") )  ;; Make a unique tag within a local scope.
  713.                     ;; No other data object is EQ? to this tag.
  714.   (set! MAKE-INSTANCE
  715.      (lambda (dispatcher) (cons instance-tag dispatcher)))
  716.  
  717.   (set! INSTANCE?
  718.      (lambda (obj) (and (pair? obj) (eq? (car obj) instance-tag))))
  719. )
  720.  
  721. ;; DEFINE-OPERATION
  722.  
  723. (define-syntax DEFINE-OPERATION
  724.   (syntax-rules ()
  725.     ((define-operation (<name> <inst> <arg> ...) <exp1> <exp2> ...)
  726.      ;;=>
  727.      (define <name>
  728.        (letrec ( (self
  729.                   (lambda (<inst> <arg> ...)
  730.            (cond
  731.              ((and (instance? <inst>) 
  732.                    ((instance-dispatcher <inst>) self))
  733.               => (lambda (operation) (operation <inst> <arg> ...))
  734.                      )
  735.              (else <exp1> <exp2> ...)
  736.             ) ) )  )
  737.         self)
  738.   ))
  739.   ((define-operation (<name> <inst> <arg> ...) ) ;; no body
  740.    ;;=>
  741.    (define <name>
  742.      (letrec ( (self
  743.                 (lambda (<inst> <arg> ...)
  744.            (cond
  745.                ((and (instance? <inst>) 
  746.                      ((instance-dispatcher <inst>) self))
  747.                 => (lambda (operation) (operation <inst> <arg> ...))
  748.                        )
  749.                (else (error "Operation not handled:" '<name> <inst>))
  750.               ) ) )  )
  751.         self)
  752.   ))
  753. ) )
  754.  
  755.  
  756. ;; DEFINE-PREDICATE
  757.  
  758. (define-syntax DEFINE-PREDICATE
  759.   (syntax-rules ()
  760.     ((define-predicate <name>)
  761.      ;;=>
  762.      (define-operation (<name> obj) #f)
  763.     )
  764. ) )
  765.  
  766.  
  767. ;; OBJECT
  768.  
  769. (define-syntax OBJECT
  770.   (syntax-rules ()
  771.     ((object ((<name> <self> <arg> ...) <exp1> <exp2> ...) ...)
  772.     ;;=>
  773.      (let ( (table
  774.            (list (cons <name>
  775.                    (lambda (<self> <arg> ...) <exp1> <exp2> ...))
  776.                       ...
  777.              ) ) 
  778.             )
  779.       (make-instance
  780.         (lambda (op)
  781.       (cond
  782.             ((assq op table) => cdr)
  783.             (else #f)
  784. ) ) )))) )
  785.  
  786.  
  787. ;; OBJECT with MULTIPLE INHERITANCE  {First Found Rule}
  788.  
  789. (define-syntax OBJECT-WITH-ANCESTORS
  790.   (syntax-rules ()
  791.     ((object-with-ancestors ( (<ancestor1> <init1>) ... ) <operation> ...)
  792.     ;;=>
  793.      (let ( (<ancestor1> <init1>) ...  )
  794.       (let ( (child (object <operation> ...)) )
  795.        (make-instance
  796.          (lambda (op) 
  797.             (or ((instance-dispatcher child) op)
  798.             ((instance-dispatcher <ancestor1>) op) ...
  799.        ) )  )
  800.     )))
  801. ) )
  802.  
  803.  
  804. ;; OPERATE-AS  {a.k.a. send-to-super}
  805.  
  806. ; used in operations/methods
  807.  
  808. (define-syntax OPERATE-AS
  809.   (syntax-rules ()
  810.    ((operate-as <component> <op> <composit> <arg> ...)
  811.    ;;=>
  812.     (((instance-dispatcher <component>) <op>) <composit> <arg> ...)
  813.   ))
  814. )
  815.  
  816.  
  817. ;;            --- End YASOS ---
  818.  
  819.  
  820. *******************
  821. * LISTING: format *
  822. *******************
  823. ;
  824. ; FILE:        "format.scm"
  825. ; IMPLEMENTS:    Format function {Scheme} -- see documentation below.
  826. ; AUTHOR:    Ken Dickey
  827. ; DATE:        1988
  828. ; LAST UPDATED:    1992 January 8 -- now implements ~& option
  829. ;        1991 November 25 -- now uses string ports
  830.  
  831. ; NOTES:    Imports PRETTY-PRINT (~g) and OBJECT->STRING
  832.  
  833. ;        Pretty print and various other code is available via ftp
  834. ;        from the Scheme Repository on nexus.yorku.ca [130.63.9.1] 
  835. ;        under pub/scheme.  Contact: Ozan Yigit: oz@nexus.yorku.ca.
  836.  
  837. ;;  ========
  838. ;;  FUNCTION: (FORMAT <port> <format-string> . <args>)
  839. ;;  ========
  840. ;;  
  841. ;;  RESULT: returns zero-length symbol or a string; has side effect of
  842. ;;  printing according to <format-string>.  If <port> is #t the output is
  843. ;;  to the current output port.  If <port> is #f, a formatted string is
  844. ;;  returned as the result of the call.  Otherwise <port> must be an
  845. ;;  output port.  <format-string> must be a string.  Characters are output
  846. ;;  as if the string were output by the DISPLAY function with the
  847. ;;  exception of those prefixed by a tilde (~) as follows [note that options
  848. ;;  which take arguments remove them from the argument list (they are said to
  849. ;;  be `consumed')]:
  850. ;;
  851. ;;option  mnemonic: description
  852. ;;------  ------------------------
  853. ;;   ~a  any: display the argument (as for humans).
  854. ;;   ~s  slashified: write the argument (as for parsers).
  855. ;;   ~d  decimal: the integer argument is output in decimal format.
  856. ;;   ~x  hexadecimal: the integer argument is output in hexadecimal format.
  857. ;;   ~o  octal: the integer argument is output in octal format.
  858. ;;   ~b  binary: the integer argument is output in binary format.
  859. ;;   ~p  plural: if the argument is > than 1, a lower case 's' is printed.
  860. ;;   ~c  character: the next argument is displayed as a character.
  861. ;;   ~_  space: output a space character.
  862. ;;   ~%  newline: output a newline character.
  863. ;;   ~&  freshline: unless at the beginning of a line, same as ~%, else ignored
  864. ;;   ~~  tilde: output a tilde.
  865. ;;   ~t  tab: output a tab charcter. **implemented, but system dependent**
  866. ;;   ~g  glorify: pretty print the argument (typically an s-expression).
  867. ;;   ~|  page separator: output a page separator.
  868. ;;   ~?  indirection: take the next argument as a format string and consume
  869. ;;       further arguments as appropriate, then continue to process the current
  870. ;;       format string.
  871. ;;
  872.  
  873. ;----- IMPLEMENTATION SPECIFIC OPTIMIZATIONS
  874.  
  875. ;; (##declare (standard-bindings) (fixnum)) ;; GAMBIT (v1.71)
  876.  
  877. ;---------- FORMAT
  878.  
  879.  
  880. (define FORMAT
  881.  
  882.  (let ( (LAST-WAS-NEWLINE #f)  ; state shared between invocations
  883.     (ASCII-TAB   (integer->char  9))
  884.     (ASCII-FF    (integer->char 12))
  885.     (DONT-PRINT  (string->symbol ""))  ;; a zero character symbol
  886.       )
  887.  
  888.   (lambda (<output-port> <format-string> . <args>)
  889.  
  890.   (letrec (
  891.        (PORT (cond ((output-port? <output-port>) <output-port>)
  892.                ((eq? <output-port> #t) (current-output-port))
  893.                ((eq? <output-port> #f) (open-output-string))
  894.                (else (error "format: bad port -> " <output-port>)))
  895.            )
  896.        (RETURN-VALUE  (if (eq? <output-port> #f)  ;; format to a string
  897.                   (lambda () (get-output-string port))
  898.                   (lambda () dont-print))
  899.            )
  900.           )
  901.  
  902.     (define (FORMAT-HELP format-strg arglyst)
  903.  
  904.       (letrec
  905.       (
  906.        (LENGTH-OF-FORMAT-STRING (string-length format-strg))
  907.  
  908.        (ANYCHAR-DISPATCH
  909.         (lambda (pos arglist last-char-was-nl)
  910.           (if (>= pos length-of-format-string)
  911.           (begin
  912.             (set! last-was-newline last-char-was-nl)
  913.             arglist ; used for ~? continuance
  914.           )
  915.           (let ( (char (string-ref format-strg pos)) )
  916.             (cond
  917.              ((eq? char #\~)
  918.               (tilde-dispatch (+ pos 1) arglist last-char-was-nl))
  919.              (else
  920.               (write-char char port)
  921.               (anychar-dispatch (+ pos 1) arglist #f)
  922.               ))
  923.             ))
  924.           )) ; end anychar-dispatch
  925.  
  926.         (TILDE-DISPATCH
  927.          (lambda (pos arglist last-char-was-nl)
  928.            (cond
  929.         ((>= pos length-of-format-string)
  930.          (write-char #\~ port) ; tilde at end of string is just output
  931.          (set! last-was-newline last-char-was-nl)
  932.          arglist ; used for ~? continuance
  933.          )
  934.         (else
  935.          (case (char-upcase (string-ref format-strg pos))
  936.            ((#\A)    ; Any -- for humans
  937.             (display (car arglist) port)
  938.             (anychar-dispatch (+ pos 1) (cdr arglist) #f)
  939.             )
  940.            ((#\S)    ; Slashified -- for parsers
  941.             (write (car arglist) port)
  942.             (anychar-dispatch (+ pos 1) (cdr arglist) #f)
  943.             )
  944.            ((#\D)    ; Decimal
  945.             (display (number->string (car arglist) 10) port)
  946.             (anychar-dispatch (+ pos 1) (cdr arglist) #f)
  947.             )
  948.            ((#\X)    ; Hexadecimal
  949.             (display (number->string (car arglist) 16) port)
  950.             (anychar-dispatch (+ pos 1) (cdr arglist) #f)
  951.             )
  952.            ((#\O)    ; Octal
  953.             (display (number->string (car arglist)  8) port)
  954.             (anychar-dispatch (+ pos 1) (cdr arglist) #f)
  955.             )
  956.            ((#\B)    ; Binary
  957.             (display (number->string (car arglist)  2) port)
  958.             (anychar-dispatch (+ pos 1) (cdr arglist) #f)
  959.             )
  960.            ((#\C)    ; Character
  961.             (write-char (car arglist) port) 
  962.             (anychar-dispatch (+ pos 1) (cdr arglist) #f)
  963.             )
  964.            ((#\P)    ; Plural
  965.             (if (= (car arglist) 1)
  966.             #f ; no action
  967.             (write-char #\s port))
  968.             (anychar-dispatch (+ pos 1) (cdr arglist) #f)
  969.             )
  970.            ((#\~)    ; Tilde
  971.             (write-char #\~ port)
  972.             (anychar-dispatch (+ pos 1) arglist #f)
  973.             )
  974.            ((#\%)    ; Newline
  975.             (write-char #\newline port)
  976.             (anychar-dispatch (+ pos 1) arglist #t)
  977.             )
  978.            ((#\_)    ; Space
  979.             (write-char #\space port)
  980.             (anychar-dispatch (+ pos 1) arglist #f)
  981.             )
  982.            ((#\&)    ; Freshline
  983.             (if (not last-char-was-nl)
  984.             (write-char #\newline port))
  985.             (anychar-dispatch (+ pos 1) arglist #t)
  986.             )
  987.            ((#\T)    ; Tab -- Implementation dependent
  988.             (write-char ASCII-TAB port) 
  989.             (anychar-dispatch (+ pos 1) arglist #f)
  990.             )
  991.                    ((#\|)    ; Page Separator -- Implementation dependent
  992.                     (write-char ascii-ff port) ;; use form-feed char
  993.                     (anychar-dispatch (+ pos 1) arglist #t) ; counts as newline
  994.                     )
  995.            ((#\G)    ; Pretty-print {T}
  996.             (if (eq? port #f)
  997.             (display (pretty-print-to-string (car arglist)) port)
  998.             (pretty-print (car arglist) port))
  999.             (anychar-dispatch (+ pos 1) (cdr arglist) #t) ; check this!
  1000.             )
  1001.            ;; {"~?" in Common Lisp is "~K" in T}
  1002.            ((#\?)    ; indirection -- take next arg as format string.
  1003.             (set! last-was-newline last-char-was-nl)
  1004.             (anychar-dispatch (+ pos 1) 
  1005.                       (format-help (car arglist) (cdr arglist))
  1006.                       last-was-newline)
  1007.                               ; Note: format-help returns unused args
  1008.             )
  1009.            (else
  1010.                     (error "FORMAT: unknown tilde escape" 
  1011.                            (string-ref format-strg pos)))
  1012.            )))
  1013.            )) ; end tilde-dispatch
  1014.  
  1015.         )             
  1016.  
  1017.     ; FORMAT-HELP MAIN
  1018.     (anychar-dispatch 0 arglyst last-was-newline)
  1019.  
  1020.     )) ; end format-help
  1021.  
  1022.  
  1023.     ; FORMAT MAIN
  1024.     (format-help <format-string> <args>)
  1025.     (return-value)
  1026.     
  1027.     ) ; end let
  1028. ))) ; end format
  1029.  
  1030.  
  1031. ;;----------------------------------E-O-F----------------------------------;;
  1032.  
  1033.