home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / World_Of_Computer_Software-02-385-Vol-1of3.iso / s / s48.zip / VM / PRIM.SCM < prev    next >
Text File  |  1992-06-17  |  15KB  |  476 lines
  1. ; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
  2. ; Copyright (c) 1992 by Richard Kelsey and Jonathan Rees.  See file COPYING.
  3.  
  4.  
  5. ; This is file prim.scm.
  6. ; Requires DEFINE-PRIMITIVE macro.
  7.  
  8. ;;;; VM data manipulation primitives
  9.  
  10. ; Input checking and coercion
  11.  
  12. (define (input-type pred coercer)  ;Alonzo wins
  13.   (lambda (f) (f pred coercer)))
  14.  
  15. (define (input-type-predicate type) (type (lambda (x y) y x)))
  16. (define (input-type-coercion type)  (type (lambda (x y) x y)))
  17.  
  18. (define (no-coercion x) x)
  19.  
  20. (define any->     (input-type (lambda (x) x #t) no-coercion))
  21. (define fixnum->  (input-type fixnum?  extract-fixnum))
  22. (define char->    (input-type vm-char? extract-char))
  23. (define boolean-> (input-type boolean? extract-boolean))
  24.  
  25. ; Output coercion
  26.  
  27. (define (return val)
  28.   (set! *val* val)
  29.   (goto interpret))
  30.  
  31. (define return-any return)
  32.  
  33. (define (return-boolean x)
  34.   (return (enter-boolean x)))
  35.  
  36. (define (return-fixnum x)
  37.   (return (enter-fixnum x)))
  38.  
  39. (define (return-char x)
  40.   (return (enter-char x)))
  41.  
  42. (define (return-unspecified x)
  43.   x ;ignored
  44.   (return unspecified))
  45.  
  46. ; Scalar primitives
  47.  
  48. (define-primitive op/eq? (any-> any->) vm-eq? return-boolean)
  49.  
  50. ; Rudimentary generic arithmetic.  Incomplete and confusing.
  51. ;  How to modularize for VM's like Maclisp that have generic arithmetic
  52. ;  built-in?
  53.  
  54. ; These predicates are used to characterize the numeric representations that
  55. ; are implemented in the VM.
  56.  
  57. (define primitive-number?  fixnum?)
  58. (define primitive-real?    fixnum?)
  59. (define primitive-integer? fixnum?)
  60.  
  61. (define number->  (input-type primitive-number?  no-coercion))
  62. (define real->    (input-type primitive-real?    no-coercion))
  63. (define integer-> (input-type primitive-integer? no-coercion))
  64.  
  65. (define-primitive op/number?   (any->) vm-number?   return-boolean)
  66.  
  67. (define (define-numeric-predicate op)
  68.   (define-primitive op
  69.     (any->)
  70.     (lambda (n)
  71.       (cond ((fixnum? n)
  72.          (return (enter-boolean #t)))
  73.         ((extended-number? n)
  74.          (raise-exception1 0 n))
  75.         (else
  76.          (return (enter-boolean #f)))))))
  77.  
  78. (define-numeric-predicate op/integer?)
  79. (define-numeric-predicate op/rational?)
  80. (define-numeric-predicate op/real?)
  81. (define-numeric-predicate op/complex?)
  82.  
  83. ; These primitives have a simple answer in the case of fixnums; for all other
  84. ; they punt to the run-time system.
  85.  
  86. (define-primitive op/exact?      (number->) (lambda (n) #t) return-boolean)
  87. (define-primitive op/real-part   (number->) (lambda (n) (return n)))
  88. (define-primitive op/imag-part   (number->) (lambda (n)
  89.                           (return (enter-fixnum 0))))
  90. (define-primitive op/floor       (number->) (lambda (n) (return n)))
  91. (define-primitive op/numerator   (number->) (lambda (n) (return n)))
  92. (define-primitive op/denominator (number->) (lambda (n)
  93.                           (return (enter-fixnum 1))))
  94. (define-primitive op/angle       (number->) (lambda (n)
  95.                           (if (>= n 0)
  96.                           (return (enter-fixnum 0))
  97.                           (raise-exception1 0 n))))
  98.  
  99. ; beware of (abs least-fixnum)
  100. (define-primitive op/magnitude   (number->)
  101.   (lambda (n)
  102.     (let ((r (abs n)))
  103.       (if (too-big-for-fixnum? r)
  104.       (raise-exception1 0 n)
  105.       (return (enter-fixnum r))))))
  106.  
  107. ; These primitives all just raise an exception and let the run-time system do
  108. ; the work.
  109.  
  110. (define (define-punt-primitive op)
  111.   (define-primitive op (number->) (lambda (n) (raise-exception1 0 n))))
  112.  
  113. (define-punt-primitive op/exact->inexact)
  114. (define-punt-primitive op/inexact->exact)
  115. (define-punt-primitive op/exp)
  116. (define-punt-primitive op/log)
  117. (define-punt-primitive op/sin)
  118. (define-punt-primitive op/cos)
  119. (define-punt-primitive op/tan)
  120. (define-punt-primitive op/asin)
  121. (define-punt-primitive op/acos)
  122. (define-punt-primitive op/atan)
  123. (define-punt-primitive op/sqrt)
  124. (define-punt-primitive op/make-polar)
  125. (define-punt-primitive op/make-rectangular)
  126.  
  127. (define (arithmetic-overflow x y)
  128.   (raise-exception2 0 x y))
  129.  
  130. (define (arith op)
  131.   (lambda (x y)
  132.     (op x y return arithmetic-overflow)))
  133.  
  134. (define-primitive op/+         (number->  number->) (arith add-carefully))
  135. (define-primitive op/-         (number->  number->) (arith subtract-carefully))
  136. (define-primitive op/*         (number->  number->) (arith multiply-carefully))
  137. (define-primitive op//         (number->  number->) (arith divide-carefully))
  138. (define-primitive op/quotient  (integer-> integer->) (arith quotient-carefully))
  139. (define-primitive op/remainder (integer-> integer->) (arith remainder-carefully))
  140. (define-primitive op/=         (number->  number->) vm-= return-boolean)
  141. (define-primitive op/<         (real->    real->)   vm-< return-boolean)
  142.  
  143. (define-primitive op/char?       (any->) vm-char? return-boolean)
  144. (define-primitive op/char=?      (char-> char->) vm-char=? return-boolean)
  145. (define-primitive op/char<?      (char-> char->) vm-char<? return-boolean)
  146. (define-primitive op/char->ascii (char->) char->ascii return-fixnum)
  147.  
  148. (define-primitive op/ascii->char
  149.   (fixnum->)
  150.   (lambda (x)
  151.     (if (or (> x 255) (< x 0))
  152.         (raise-exception1 0 (enter-fixnum x))
  153.     (return (enter-char (ascii->char x))))))
  154.  
  155. (define-primitive op/eof-object?
  156.   (any->)
  157.   (lambda (x) (vm-eq? x eof-object))
  158.   return-boolean)
  159.  
  160. (define-primitive op/bitwise-not (fixnum->)          bitwise-not return-fixnum)
  161. (define-primitive op/bitwise-and (fixnum-> fixnum->) bitwise-and return-fixnum)
  162. (define-primitive op/bitwise-ior (fixnum-> fixnum->) bitwise-ior return-fixnum)
  163. (define-primitive op/bitwise-xor (fixnum-> fixnum->) bitwise-xor return-fixnum)
  164.  
  165. (define-primitive op/arithmetic-shift
  166.   (fixnum-> fixnum->)
  167.   (lambda (value count)
  168.     (if (< count 0)
  169.     (ashr value (- 0 count))
  170.     (let ((result (extract-fixnum (enter-fixnum (ashl value count)))))
  171.       (if (and (= value (ashr result count))
  172.            (if (>= value 0)
  173.                (>= result 0)
  174.                (< result 0)))
  175.           result
  176.           (arithmetic-overflow (enter-fixnum value)
  177.                    (enter-fixnum count))))))
  178.   return-fixnum)
  179.  
  180.  
  181. ; Synchronize this with struct.scm.
  182.  
  183. (define-primitive-structure-type #t pair cons
  184.   (car set-car!)
  185.   (cdr set-cdr!))
  186.  
  187. (define-primitive-structure-type #t symbol make-symbol
  188.   (symbol->string))
  189.  
  190. (define-primitive-structure-type #f closure make-closure
  191.   (closure-template)
  192.   (closure-env))
  193.  
  194. (define-primitive-structure-type #f location make-location
  195.   (contents set-contents!)
  196.   (location-id))
  197.  
  198. (define location-> (input-type location? no-coercion))
  199.  
  200. (define-primitive op/location-defined? (location->)
  201.   (lambda (loc)
  202.     (return-boolean (or (not (undefined? (contents loc)))
  203.            (= (contents loc) unassigned-marker)))))
  204.  
  205. (define-primitive op/set-location-defined?! (location-> boolean->)
  206.   (lambda (loc value)
  207.     (cond ((not value)
  208.        (set-contents! loc unbound-marker))
  209.       ((undefined? (contents loc))
  210.        (set-contents! loc unassigned-marker)))
  211.     (return unspecified)))
  212.  
  213. ; (Note: no port primitives.)
  214.  
  215. (define (vector-maker size make set)
  216.   (lambda (len init)
  217.     (let ((finish (lambda (init)
  218.             (let ((v (make len (preallocate-space (size len)))))
  219.               ;; Clear out storage
  220.               (do ((i (- len 1) (- i 1)))
  221.               ((< i 0)
  222.                (return v))
  223.             (set v i init))))))
  224.       (cond ((not (>= len 0))
  225.          (raise-exception2 0 (enter-fixnum len) init))
  226.         ((available? (size len))
  227.          (finish init))
  228.         (else
  229.          (let ((init (collect-saving-temp init)))
  230.            (if (available? (size len))
  231.            (finish init)
  232.            (raise-exception2 0 (enter-fixnum len) init))))))))
  233.  
  234. (define (vector-referencer length ref coerce)
  235.   (lambda (v index)
  236.     (cond ((valid-index? index (length v))
  237.            (coerce (ref v index)))
  238.           (else
  239.            (raise-exception2 0 v (enter-fixnum index))))))
  240.  
  241. (define (vector-setter length set)
  242.   (lambda (v index val)
  243.     (cond ((valid-index? index (length v))
  244.            (set v index val)
  245.            (return unspecified))
  246.           (else
  247.            (raise-exception2 0 v (enter-fixnum index))))))
  248.  
  249. (define-vector-type vector          any #t)
  250. (define-vector-type record          any #f)
  251. (define-vector-type extended-number any #f)
  252. (define-vector-type continuation    any #f)
  253. (define-vector-type string          char #t)
  254. (define-vector-type code-vector     fixnum #f)
  255.  
  256. (define string-> (input-type vm-string? no-coercion))
  257. (define vector-> (input-type vm-vector? no-coercion))
  258.  
  259. ; I/O primitives
  260.  
  261. (define (vm-input-port? obj)
  262.   (and (port? obj)
  263.        (= (port-mode obj) (enter-fixnum for-input))))
  264.  
  265. (define (vm-output-port? obj)
  266.   (and (port? obj)
  267.        (= (port-mode obj) (enter-fixnum for-output))))
  268.  
  269. (define port->        (input-type port?           no-coercion))
  270. (define input-port->  (input-type vm-input-port?  no-coercion))
  271. (define output-port-> (input-type vm-output-port? no-coercion))
  272.  
  273. (define-primitive op/halt (any->)
  274.   (lambda (status)
  275.     (halt-machine status)))
  276.  
  277. (define-primitive op/input-port? (any->) vm-input-port? return-boolean)
  278. (define-primitive op/output-port? (any->) vm-output-port? return-boolean)
  279.  
  280. (define-consing-primitive op/open-port (string-> fixnum->)
  281.   (lambda (ignore) port-size)
  282.   (lambda (filename mode key)
  283.     (let loop ((index (find-port-index)) (filename filename))
  284.       (cond (index
  285.              (let* ((port
  286.                      (cond ((= mode for-output)
  287.                             (open-output-file (extract-string filename)))
  288.                            (else        ;(= mode for-input)
  289.                             (open-input-file (extract-string filename))))))
  290.                (if port
  291.                    (let ((vm-port (make-port (enter-fixnum mode)
  292.                          (enter-fixnum index)
  293.                          false
  294.                          filename
  295.                          key)))
  296.                      (use-port-index! index vm-port port)
  297.                      (return vm-port))
  298.                    (return false))))
  299.             (else
  300.              (let ((filename (collect-saving-temp filename)))
  301.            (let ((index (find-port-index)))
  302.          (if index
  303.              (loop index filename)
  304.              (error "ran out of ports")))))))))
  305.  
  306. (define-primitive op/close-port (port->) close-port return-unspecified)
  307.  
  308. (define-primitive op/read-char (input-port->)
  309.   (lambda (port)
  310.     (if (open? port)
  311.         (let ((c (peeked-char port)))
  312.           (return (cond ((false? c)
  313.                          (vm-read-char (extract-port port)
  314.                        (lambda (c) (enter-char c))
  315.                        (lambda () eof-object)))
  316.                         (else
  317.                          (set-peeked-char! port false)
  318.                          c))))
  319.         (raise-exception1 0 port))))
  320.  
  321. (define-primitive op/peek-char (input-port->)
  322.   (lambda (port)
  323.     (if (open? port)
  324.         (let ((c (peeked-char port)))
  325.           (return (cond ((false? c)
  326.                          (let ((c (vm-read-char (extract-port port)
  327.                         (lambda (c) (enter-char c))
  328.                         (lambda () eof-object))))
  329.                            (set-peeked-char! port c)
  330.                            c))
  331.                         (else c))))
  332.         (raise-exception1 0 port))))
  333.  
  334. (define-primitive op/write-char (char-> output-port->)
  335.   (lambda (c port)
  336.     (cond ((open? port)
  337.            (write-char c (extract-port port))
  338.            (return unspecified))
  339.       (else
  340.        (raise-exception2 0 c port)))))
  341.  
  342. (define-primitive op/write-string (string-> output-port->)
  343.   (lambda (s port)
  344.     (cond ((open? port)
  345.        (write-vm-string s (extract-port port))
  346.        (return unspecified))
  347.       (else
  348.        (raise-exception2 0 s port)))))
  349.  
  350. (define-primitive op/force-output (output-port->)
  351.   (lambda (port)
  352.     (cond ((open? port)
  353.            (force-output (extract-port port))
  354.            (return unspecified))
  355.       (else
  356.        (raise-exception1 0 port)))))
  357.  
  358. ; Misc
  359.  
  360. (define-primitive op/false ()
  361.   (lambda ()
  362.     (return false)))
  363.  
  364. (define-primitive op/trap (any->)
  365.   (lambda (arg)
  366.     (raise-exception1 0 arg)))
  367.  
  368. (define-primitive op/find-all-symbols (vector->)
  369.   (lambda (table)
  370.     (if (add-symbols-to-table table)
  371.     (return unspecified)
  372.     (raise-exception 0))))
  373.  
  374. ; RESUME-PROC is called when the image is resumed.
  375. ; CONTINUE-PROC is called to continue the current computation.  CONTINUE-PROC
  376. ; is not saved in the image.
  377.  
  378. (define-primitive op/write-image (string-> any-> any->)
  379.   (lambda (filename resume-proc continue-proc)
  380.     (let ((port (open-output-file (extract-string filename))))
  381.       (cond ((not port)
  382.          (raise-exception3 0 filename resume-proc continue-proc))
  383.         (else
  384.          (clear-registers)
  385.          (set! *val* resume-proc)
  386.          (interpreter-collect)
  387.          (write-image port *val*)
  388.          (close-output-port port)
  389.          (let ((continue-proc (trace-value continue-proc)))
  390.            (set! *val* continue-proc)
  391.            (set! *nargs* 0)
  392.            (goto perform-application)))))))
  393.  
  394. (define-primitive op/collect ()
  395.   (lambda ()
  396.     (set! *val* unspecified)
  397.     (interpreter-collect)
  398.     (return unspecified)))
  399.  
  400. (define-primitive op/vm (fixnum-> any->)
  401.   (lambda (key other)
  402.     (if (or (< key 0) (>= key 3))
  403.     (raise-exception2 0 (enter-fixnum key) other)
  404.     (return (cond ((= key 0)
  405.                        (enter-fixnum (available)))
  406.               ((= key 1)
  407.                (enter-fixnum (apply-primitive runtime))))))))
  408.  
  409. (define-primitive op/vm-extension (fixnum-> any->)
  410.   (lambda (key value)
  411.     (let ((return-value (extended-vm key value)))
  412.       (if (undefined? return-value)
  413.       (raise-exception2 0 (enter-fixnum key) value)
  414.       (return return-value)))))
  415.  
  416. (define-primitive op/vm-return (fixnum-> any->)
  417.   (lambda (key value)
  418.     (set! *val* value)
  419.     (halt-machine key)))
  420.  
  421. (define-primitive op/get-dynamic-state ()
  422.   (lambda () *dynamic-state*)
  423.   return-any)
  424.  
  425. (define-primitive op/set-dynamic-state! (any->)
  426.   (lambda (state)
  427.     (set! *dynamic-state* state)
  428.     unspecified)
  429.   return-any)
  430.  
  431. ; Unnecessary primitives
  432.  
  433. (define-primitive op/string=? (string-> string->) vm-string=? return-boolean)
  434.  
  435. ; Special primitive called by the reader.
  436. ; Primitive for the sake of speed.  Probably should be flushed.
  437.  
  438. (define-consing-primitive op/reverse-list->string (any-> fixnum->) 
  439.   (lambda (n) (vm-string-size n))
  440.   (lambda (l n k)
  441.     (if (not (or (vm-pair? l) (vm-eq? l null)))
  442.         (raise-exception2 0 l n)
  443.         (let ((obj (vm-make-string n k)))
  444.           (do ((l l (vm-cdr l))
  445.                (i (- n 1) (- i 1)))
  446.               ((< i 0) (return obj))
  447.             (vm-string-set! obj i (extract-char (vm-car l))))))))
  448.  
  449. (define-primitive op/string-hash (string->) vm-string-hash return-fixnum)
  450.  
  451. (define-consing-primitive op/intern (string-> vector->)
  452.   (lambda (ignore) (+ vm-symbol-size vm-pair-size))
  453.   intern
  454.   return)
  455.  
  456. (define-consing-primitive op/lookup (any-> any->)
  457.   (lambda (ignore) (+ location-size vm-pair-size))
  458.   lookup
  459.   return)
  460.  
  461. ;#|
  462. ;(define-primitive op/vector (fixnum->)
  463. ;  (let* ((min-args (next-byte))
  464. ;         (len (- *nargs* min-args))
  465. ;         (key (ensure-space (vector-size len)))
  466. ;         (vec (make-vector len)))
  467. ;    (do ((i (- len 1) (- i 1)))
  468. ;        ((= i -1)
  469. ;         (set! *val* l)
  470. ;         (set! *nargs* (+ min-args 1))
  471. ;         (goto interpret))
  472. ;      (vector-set vec i (pop)))))
  473. ;|#
  474. ; Eventually add make-table, table-ref, table-set! as primitives?
  475. ; No -- write a compiler instead.
  476.