home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / World_Of_Computer_Software-02-385-Vol-1of3.iso / s / s48.zip / MISC / XPORT.SCM < prev   
Text File  |  1992-06-18  |  5KB  |  165 lines
  1. ; Copyright (c) 1992 by Richard Kelsey and Jonathan Rees.  See file COPYING.
  2.  
  3.  
  4. ; Extensible ports
  5.  
  6. ; Input ports
  7.  
  8. (define-record-type extensible-input-port
  9.   (local-data
  10.    methods)
  11.   ())
  12.  
  13. (define make-extensible-input-port extensible-input-port-maker)
  14.  
  15. (define-record-type input-port-methods
  16.   (close-port
  17.    read-char
  18.    peek-char
  19.    current-column
  20.    current-row
  21.    )
  22.   ())
  23.  
  24. (define make-input-port-methods input-port-methods-maker)
  25.  
  26. ; Output ports
  27.  
  28. (define-record-type extensible-output-port
  29.   (local-data
  30.    methods)
  31.   ())
  32.  
  33. (define make-extensible-output-port extensible-output-port-maker)
  34.  
  35. (define-record-type output-port-methods
  36.   (close-port
  37.    write-char
  38.    write-string
  39.    force-output
  40.    fresh-line
  41.    current-column
  42.    current-row
  43.    )
  44.   ())
  45.  
  46. (define make-output-port-methods output-port-methods-maker)
  47.  
  48. ; Operations
  49.  
  50. ; CLOSE-PORT must work on both types of extensible ports.
  51.  
  52. (define-exception-handler op/close-port
  53.   (lambda (opcode args)
  54.     (let ((port (car args)))
  55.       (cond ((extensible-input-port? port)
  56.          ((input-port-methods-close-port
  57.            (extensible-input-port-methods port))
  58.           (extensible-input-port-local-data port)))
  59.         ((extensible-output-port? port)
  60.          ((output-port-methods-close-port
  61.            (extensible-output-port-methods port))
  62.           (extensible-output-port-local-data port)))
  63.         (else
  64.          (raise-port-exception opcode args))))))
  65.  
  66. (define (raise-port-exception opcode args)
  67.   (raise (make-exception opcode args)))
  68.  
  69. ; Predicates
  70. ; These won't work as the VM does not raise an exception when predicates are
  71. ; applied to records.
  72.  
  73. ;(define-exception-handler op/input-port?
  74. ;  (lambda (opcode args)
  75. ;    (extensible-input-port? (car args))))
  76.  
  77. ;(define-exception-handler op/output-port?
  78. ;  (lambda (opcode args)
  79. ;    (extensible-output-port? (car args))))
  80.  
  81. ; These will work for any code loaded subsequently...
  82.  
  83. (define (input-port? thing)
  84.   (or (call-primitively input-port? thing)
  85.       (extensible-input-port? thing)))
  86.  
  87. (define (output-port? thing)
  88.   (or (call-primitively output-port? thing)
  89.       (extensible-output-port? thing)))
  90.  
  91. ; Other methods
  92.  
  93. (define (define-input-port-method op method)
  94.   (define-exception-handler op
  95.     (lambda (opcode args)
  96.       (let ((port (car args)))
  97.     (if (extensible-input-port? port)
  98.         ((method (extensible-input-port-methods port))
  99.          (extensible-input-port-local-data port))
  100.         (raise-port-exception opcode args))))))
  101.   
  102. (define-input-port-method op/read-char input-port-methods-read-char)
  103. (define-input-port-method op/peek-char input-port-methods-peek-char)
  104.  
  105. (define (define-output-port-method op arg-count method)
  106.   (define-exception-handler op
  107.     (case arg-count
  108.       ((0)
  109.        (lambda (opcode args)
  110.      (let ((port (car args)))
  111.        (if (extensible-output-port? port)
  112.            ((method (extensible-output-port-methods port))
  113.         (extensible-output-port-local-data port))
  114.            (raise-port-exception opcode args)))))
  115.       ((1)
  116.        (lambda (opcode args)
  117.      (let ((port (cadr args)))
  118.        (if (extensible-output-port? port)
  119.            ((method (extensible-output-port-methods port))
  120.         (extensible-output-port-local-data port)
  121.         (car args))
  122.            (raise-port-exception opcode args))))))))
  123.   
  124. (define-output-port-method op/write-char   1 output-port-methods-write-char)
  125. (define-output-port-method op/write-string 1 output-port-methods-write-string)
  126. (define-output-port-method op/force-output 0 output-port-methods-force-output)
  127.  
  128. (define (make-new-port-method id input-method output-method default)
  129.   (lambda (port)
  130.     (cond ((extensible-input-port? port)
  131.        ((input-method (extensible-input-port-methods port))
  132.         (extensible-input-port-local-data port)))
  133.       ((extensible-output-port? port)
  134.        ((output-method (extensible-output-port-methods port))
  135.         (extensible-output-port-local-data port)))
  136.       (else
  137.        (default port)))))
  138.  
  139. (define current-column
  140.   (make-new-port-method 'current-column
  141.             input-port-methods-current-column
  142.             output-port-methods-current-column
  143.             (lambda (port) #f)))
  144.  
  145. (define current-row
  146.   (make-new-port-method 'current-row
  147.             input-port-methods-current-row
  148.             output-port-methods-current-row
  149.             (lambda (port) #f)))
  150.  
  151. (define (make-new-output-port-method id method default)
  152.   (lambda (port)
  153.     (if (extensible-output-port? port)
  154.     ((method (extensible-output-port-methods port))
  155.      (extensible-output-port-local-data port))
  156.     (default port))))
  157.  
  158. (define fresh-line
  159.   (make-new-output-port-method 'fresh-line
  160.                    output-port-methods-fresh-line
  161.                    newline))
  162.                                      
  163.  
  164.  
  165.