experiments/tng-scratch.scm
author Tony Garnock-Jones <tonygarnockjones@gmail.com>
Wed, 16 Jan 2019 17:15:58 +0000
changeset 438 1fe179d53161
parent 0 ea4e1a00864c
permissions -rw-r--r--
Add missing primitive implementation for the plain interpreter.
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
0
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
     1
(require (lib "9.ss" "srfi")
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
     2
	 (lib "1.ss" "srfi")
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
     3
	 "queue.ss")
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
     4
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
     5
(define *runq* (make-q))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
     6
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
     7
(define (schedule thunk)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
     8
  (enq! *runq* thunk))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
     9
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    10
(define *throw-to-mainloop* '*throw-to-mainloop-not-initialised*)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    11
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    12
(define (mainloop)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    13
  (begin
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    14
    (call-with-current-continuation (lambda (cc) (set! *throw-to-mainloop* cc)))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    15
    (if (q-empty? *runq*)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    16
	(wait-for-events)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    17
	(begin
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    18
	  ((deq! *runq*))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    19
	  (mainloop)))))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    20
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    21
(define (throw-to-mainloop)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    22
  (*throw-to-mainloop* #f))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    23
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    24
(define (wait-for-events) ;; %%%
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    25
  (display "Waiting for events.")
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    26
  (newline)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    27
  (exit))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    28
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    29
(define-record-type 
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    30
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    31
(define-record-type oop
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    32
  (make-oop outputs input slots)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    33
  oop?
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    34
  (outputs oop-outputs set-oop-outputs!)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    35
  (input oop-input set-oop-input!)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    36
  (slots oop-slots set-oop-slots!))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    37
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    38
(define-record-type input-handler
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    39
  (make-input-handler next proc datum)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    40
  input-handler?
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    41
  (next input-handler-next)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    42
  (proc input-handler-proc)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    43
  (datum input-handler-datum))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    44
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    45
(define *nil* '*nil*)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    46
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    47
(define (primitive-new n)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    48
  (make-oop (make-q) #f (make-vector n *nil*)))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    49
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    50
(define (oop-ref o n)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    51
  (vector-ref (oop-slots o) n))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    52
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    53
(define (oop-set! o n x)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    54
  (vector-set! (oop-slots o) n x))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    55
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    56
(define (oop-length o)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    57
  (vector-length (oop-slots o)))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    58
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    59
(define (oop-send-full! oop message)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    60
  (let ((handler (oop-input oop)))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    61
    (if (not handler)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    62
	(enq! (oop-outputs oop) message)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    63
	(schedule (lambda () ((input-handler-proc handler)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    64
			      (input-handler-datum handler)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    65
			      #f
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    66
			      message))))))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    67
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    68
;; Channel send
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    69
;;   - RPC service ready
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    70
;;     (A) - if (isa message <message>),
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    71
;;              call service with selector+args, collect result, send to continuation
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    72
;;              else ERROR <message> expected
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    73
;;   - reader ready
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    74
;;     (B) - schedule reader action
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    75
;;   - none ready
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    76
;;     (C) - enqueue message
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    77
;; Channel receive
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    78
;;   - RPC client ready
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    79
;;     - as for (B)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    80
;;   - sender ready
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    81
;;     - as for (B)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    82
;;   - none ready
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    83
;;     (D) - enqueue reader
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    84
;; RPC client
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    85
;;   - RPC service ready
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    86
;;     (E) - call service with selector+args, returning result directly
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    87
;;   - reader ready
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    88
;;     (F) - build message and schedule reader action
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    89
;;   - none ready
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    90
;;     (G) - build message and enqueue
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    91
;; RPC service
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    92
;;   - RPC client ready
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    93
;;     - as for (A)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    94
;;   - sender ready
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    95
;;     - as for (A)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    96
;;   - none ready
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    97
;;     (H) - enqueue RPC service
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    98
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    99
(define (oop-send-fast! oop selector argv)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   100
  (let ((handler (oop-input oop)))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   101
    (if (not handler)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   102
	(call-with-current-continuation
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   103
	 (lambda (k)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   104
	   (let ((message (make-message k selector argv)))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   105
	     (enq! (oop-outputs oop) message)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   106
	     (throw-to-mainloop))))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   107
	((input-handler-proc handler)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   108
	 (input-handler-datum handler)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   109
	 selector
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   110
	 argv))))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   111
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   112
(define (*restoring-handler* datum selector message)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   113
  (set-oop-input! (vector-ref datum 0)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   114
		  (vector-ref datum 1))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   115
  ((vector-ref datum 2)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   116
   (vector-ref datum 3)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   117
   selector
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   118
   message))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   119
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   120
(define (oop-hook-oneshot-input! oop handler-proc handler-datum)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   121
  (let ((outputs (oop-outputs oop)))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   122
    (if (q-empty? outputs)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   123
	(let ((old-handler (oop-input oop)))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   124
	  (set-oop-input! oop (make-input-handler *restoring-handler*
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   125
						  (vector oop
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   126
							  old-handler
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   127
							  handler-proc
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   128
							  handler-datum))))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   129
	(let ((message (deq! outputs)))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   130
	  (schedule
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   131
	  (handler-proc
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   132
	   handler-datum
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   133
	   #f
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   134
	   message)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   135
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   136
(define (oop-hook-repeating-input! oop handler-proc handler-datum)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   137
  (set-oop-input! oop (make-input-handler handler-proc
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   138
					  handler-datum)))