home *** CD-ROM | disk | FTP | other *** search
/ MacFormat 1994 November / macformat-018.iso / Utility Spectacular / Developer / macgambit-20-compiler-src-p2 / Runtime (.scm & .s) / header.scm < prev    next >
Encoding:
Text File  |  1994-07-26  |  16.1 KB  |  446 lines  |  [TEXT/gamI]
  1. (##declare
  2.   (multilisp)
  3.   (extended-bindings)
  4.   (not safe)
  5.   (not autotouch)
  6.   (block)
  7.   (fixnum))
  8.  
  9. (##include "config.scm") ; include target dependent stuff
  10.  
  11. ;------------------------------------------------------------------------------
  12.  
  13. ; Object representation:
  14.  
  15. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  16.  
  17. ; Symbol objects
  18.  
  19. ; A symbol is represented by an object vector of length 3
  20. ; slot 0 = symbol string
  21. ; slot 1 = property list
  22. ; slot 2 = corresponding global variable
  23.  
  24. (##define-macro (symbol-make str)
  25.   `(##vector-set!
  26.      (##vector-set!
  27.        (##vector-set!
  28.          (##subtype-set! (##make-vector 3 #f) (subtype-symbol))
  29.          2
  30.          #f)
  31.        1
  32.        '())
  33.      0
  34.      ,str))
  35.  
  36. (##define-macro (symbol-string s)          `(##vector-ref ,s 0))
  37. (##define-macro (symbol-string-set! s x)   `(##vector-set! ,s 0 ,x))
  38. (##define-macro (symbol-plist s)           `(##vector-ref ,s 1))
  39. (##define-macro (symbol-plist-set! s x)    `(##vector-set! ,s 1 ,x))
  40. (##define-macro (symbol-glob-var s)        `(##vector-ref ,s 2))
  41. (##define-macro (symbol-glob-var-set! s x) `(##vector-set! ,s 2 ,x))
  42.  
  43. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  44.  
  45. ; Port objects
  46.  
  47. ; A port is represented by an object vector of length 11
  48. ; slot 0 = 0 for input port, 1 for input-output, 2 for output port (type+4 when closed)
  49. ; slot 1 = filename
  50. ; slot 2 = read procedure
  51. ; slot 3 = write procedure
  52. ; slot 4 = ready procedure
  53. ; slot 5 = close procedure
  54. ; slot 6 = pos currently at in read buffer
  55. ; slot 7 = length of active part of read buffer
  56. ; slot 8 = read buffer
  57. ; slot 9 = write buffer
  58. ; slot 10 = misc.
  59.  
  60. (##define-macro (port-make)
  61.   `(##subtype-set! (##make-vector 11 #f) (subtype-port)))
  62.  
  63. (##define-macro (port-kind p)         `(##vector-ref ,p 0))
  64. (##define-macro (port-kind-set! p x)  `(##vector-set! ,p 0 ,x))
  65. (##define-macro (port-name p)         `(##vector-ref ,p 1))
  66. (##define-macro (port-name-set! p x)  `(##vector-set! ,p 1 ,x))
  67. (##define-macro (port-read p)         `(##vector-ref ,p 2))
  68. (##define-macro (port-read-set! p x)  `(##vector-set! ,p 2 ,x))
  69. (##define-macro (port-write p)        `(##vector-ref ,p 3))
  70. (##define-macro (port-write-set! p x) `(##vector-set! ,p 3 ,x))
  71. (##define-macro (port-ready p)        `(##vector-ref ,p 4))
  72. (##define-macro (port-ready-set! p x) `(##vector-set! ,p 4 ,x))
  73. (##define-macro (port-close p)        `(##vector-ref ,p 5))
  74. (##define-macro (port-close-set! p x) `(##vector-set! ,p 5 ,x))
  75. (##define-macro (port-pos p)          `(##vector-ref ,p 6))
  76. (##define-macro (port-pos-set! p x)   `(##vector-set! ,p 6 ,x))
  77. (##define-macro (port-len p)          `(##vector-ref ,p 7))
  78. (##define-macro (port-len-set! p x)   `(##vector-set! ,p 7 ,x))
  79. (##define-macro (port-rbuf p)         `(##vector-ref ,p 8))
  80. (##define-macro (port-rbuf-set! p x)  `(##vector-set! ,p 8 ,x))
  81. (##define-macro (port-wbuf p)         `(##vector-ref ,p 9))
  82. (##define-macro (port-wbuf-set! p x)  `(##vector-set! ,p 9 ,x))
  83. (##define-macro (port-misc p)         `(##vector-ref ,p 10))
  84. (##define-macro (port-misc-set! p x)  `(##vector-set! ,p 10 ,x))
  85.  
  86. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  87.  
  88. ; Bignum objects
  89.  
  90. ; A bignum is represented by a word vector
  91. ; slot 0    = sign
  92. ; slot 1    = least significant digit
  93. ; slot 2... = other digits
  94.  
  95. (##define-macro (bignum-make n)
  96.   `(##subtype-set! (##make-vector16 ,n 0) (subtype-bignum)))
  97.  
  98. (##define-macro (bignum-length x)        `(##vector16-length ,x))
  99. (##define-macro (bignum-shrink! x n)     `(##vector16-shrink! ,x ,n))
  100. (##define-macro (bignum-digit-ref x i)   `(##vector16-ref ,x ,i))
  101. (##define-macro (bignum-digit-set! x i y) `(##vector16-set! ,x ,i ,y))
  102. (##define-macro (bignum-sign x)          `(##vector16-ref ,x 0))
  103. (##define-macro (bignum-sign* x)         `(##fixnum.- 1 (##vector16-ref ,x 0)))
  104. (##define-macro (bignum-sign-set! x n)   `(##vector16-set! ,x 0 ,n))
  105. (##define-macro (bignum-set-negative! x) `(##vector16-set! ,x 0 0))
  106. (##define-macro (bignum-negative? x)     `(##eq? (##vector16-ref ,x 0) 0))
  107. (##define-macro (bignum-set-positive! x) `(##vector16-set! ,x 0 1))
  108. (##define-macro (bignum-positive? x)     `(##eq? (##vector16-ref ,x 0) 1))
  109. (##define-macro (bignum-zero? x)         `(##eq? (##vector16-length ,x) 1))
  110. (##define-macro (bignum-odd? x)          `(##fixnum.odd? (##vector16-ref ,x 1)))
  111.  
  112. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  113.  
  114. ; Ratnum objects
  115.  
  116. ; A ratnum is represented by an object vector of length 2
  117. ; slot 0 = numerator
  118. ; slot 1 = denominator
  119.  
  120. (##define-macro (ratnum-make num den)
  121.   `(##vector-set!
  122.      (##vector-set!
  123.        (##subtype-set! (##make-vector 2 0) (subtype-ratnum))
  124.        1
  125.        ,den)
  126.      0
  127.      ,num))
  128.  
  129. (##define-macro (ratnum-numerator x)   `(##vector-ref ,x 0))
  130. (##define-macro (ratnum-denominator x) `(##vector-ref ,x 1))
  131.  
  132. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  133.  
  134. ; Cpxnum objects
  135.  
  136. ; A cpxnum is represented by an object vector of length 2
  137. ; slot 0 = real
  138. ; slot 1 = imag
  139.  
  140. (##define-macro (cpxnum-make r i)
  141.   `(##vector-set!
  142.      (##vector-set!
  143.        (##subtype-set! (##make-vector 2 0) (subtype-cpxnum))
  144.        1
  145.        ,i)
  146.      0
  147.      ,r))
  148.  
  149. (##define-macro (cpxnum-real x) `(##vector-ref ,x 0))
  150. (##define-macro (cpxnum-imag x) `(##vector-ref ,x 1))
  151.  
  152. ;------------------------------------------------------------------------------
  153.  
  154. (##define-macro (if-touches touches notouches)
  155.   (if (memq 'TOUCH ##compilation-options)
  156.     touches
  157.     notouches))
  158.  
  159. (##define-macro (touch-vars vars expr)
  160.   (if (memq 'TOUCH ##compilation-options)
  161.     `(LET ,(map (lambda (x) `(,x (##TOUCH ,x))) vars) ,expr)
  162.     expr))
  163.  
  164. (##define-macro (if-checks checks nochecks)
  165.   (if (memq 'CHECK ##compilation-options)
  166.     checks
  167.     nochecks))
  168.  
  169. (##define-macro (no-touch vars expr)
  170.   expr)
  171.  
  172. (##define-macro (no-check var form expr)
  173.   expr)
  174.  
  175. (##define-macro (trap-list-lengths form)
  176.   (define (flat x) (if (pair? x) (cons (car x) (flat (cdr x))) (list x)))
  177.   (if (list? form)
  178.     `(##TRAP-LIST-LENGTHS ',(car form) ,@(cdr form))
  179.     `(##TRAP-LIST-LENGTHS* ',(car form) ,@(flat (cdr form)))))
  180.  
  181. (##define-macro (trap-open-file form)
  182.   (define (flat x) (if (pair? x) (cons (car x) (flat (cdr x))) (list x)))
  183.   (if (list? form)
  184.     `(##TRAP-OPEN-FILE ',(car form) ,@(cdr form))
  185.     `(##TRAP-OPEN-FILE* ',(car form) ,@(flat (cdr form)))))
  186.  
  187. (##define-macro (trap-load form msg)
  188.   (define (flat x) (if (pair? x) (cons (car x) (flat (cdr x))) (list x)))
  189.   (if (list? form)
  190.     `(##TRAP-LOAD ,msg ',(car form) ,@(cdr form))
  191.     `(##TRAP-LOAD* ,msg ',(car form) ,@(flat (cdr form)))))
  192.  
  193. (##define-macro (trap-no-transcript form)
  194.   (define (flat x) (if (pair? x) (cons (car x) (flat (cdr x))) (list x)))
  195.   (if (list? form)
  196.     `(##TRAP-NO-TRANSCRIPT ',(car form) ,@(cdr form))
  197.     `(##TRAP-NO-TRANSCRIPT* ',(car form) ,@(flat (cdr form)))))
  198.  
  199. (##define-macro (check-pair var form expr)
  200.   (define (flat x) (if (pair? x) (cons (car x) (flat (cdr x))) (list x)))
  201.   `(IF-CHECKS
  202.      (IF (##PAIR? ,var)
  203.        ,expr
  204.        ,(if (list? form)
  205.           `(##TRAP-CHECK-PAIR ',(car form) ,@(cdr form))
  206.           `(##TRAP-CHECK-PAIR* ',(car form) ,@(flat (cdr form)))))
  207.      ,expr))
  208.  
  209. (##define-macro (check-weak-pair var form expr)
  210.   (define (flat x) (if (pair? x) (cons (car x) (flat (cdr x))) (list x)))
  211.   `(IF-CHECKS
  212.      (IF (##WEAK-PAIR? ,var)
  213.        ,expr
  214.        ,(if (list? form)
  215.           `(##TRAP-CHECK-WEAK-PAIR ',(car form) ,@(cdr form))
  216.           `(##TRAP-CHECK-WEAK-PAIR* ',(car form) ,@(flat (cdr form)))))
  217.      ,expr))
  218.  
  219. (##define-macro (check-queue var form expr)
  220.   (define (flat x) (if (pair? x) (cons (car x) (flat (cdr x))) (list x)))
  221.   `(IF-CHECKS
  222.      (IF (AND (##SUBTYPED? ,var) (##EQ? (##SUBTYPE ,var) (SUBTYPE-QUEUE)))
  223.        ,expr
  224.        ,(if (list? form)
  225.           `(##TRAP-CHECK-QUEUE ',(car form) ,@(cdr form))
  226.           `(##TRAP-CHECK-QUEUE* ',(car form) ,@(flat (cdr form)))))
  227.      ,expr))
  228.  
  229. (##define-macro (check-semaphore var form expr)
  230.   (define (flat x) (if (pair? x) (cons (car x) (flat (cdr x))) (list x)))
  231.   `(IF-CHECKS
  232.      (IF (AND (##SUBTYPED? ,var) (##EQ? (##SUBTYPE ,var) (SUBTYPE-SEMAPHORE)))
  233.        ,expr
  234.        ,(if (list? form)
  235.           `(##TRAP-CHECK-SEMAPHORE ',(car form) ,@(cdr form))
  236.           `(##TRAP-CHECK-SEMAPHORE* ',(car form) ,@(flat (cdr form)))))
  237.      ,expr))
  238.  
  239. (##define-macro (check-char var form expr)
  240.   (define (flat x) (if (pair? x) (cons (car x) (flat (cdr x))) (list x)))
  241.   `(IF-CHECKS
  242.      (IF (##CHAR? ,var)
  243.        ,expr
  244.        ,(if (list? form)
  245.           `(##TRAP-CHECK-CHAR ',(car form) ,@(cdr form))
  246.           `(##TRAP-CHECK-CHAR* ',(car form) ,@(flat (cdr form)))))
  247.      ,expr))
  248.  
  249. (##define-macro (check-symbol var form expr)
  250.   (define (flat x) (if (pair? x) (cons (car x) (flat (cdr x))) (list x)))
  251.   `(IF-CHECKS
  252.      (IF (##SYMBOL? ,var)
  253.        ,expr
  254.        ,(if (list? form)
  255.           `(##TRAP-CHECK-SYMBOL ',(car form) ,@(cdr form))
  256.           `(##TRAP-CHECK-SYMBOL* ',(car form) ,@(flat (cdr form)))))
  257.      ,expr))
  258.  
  259. (##define-macro (check-string var form expr)
  260.   (define (flat x) (if (pair? x) (cons (car x) (flat (cdr x))) (list x)))
  261.   `(IF-CHECKS
  262.      (IF (##STRING? ,var)
  263.        ,expr
  264.        ,(if (list? form)
  265.           `(##TRAP-CHECK-STRING ',(car form) ,@(cdr form))
  266.           `(##TRAP-CHECK-STRING* ',(car form) ,@(flat (cdr form)))))
  267.      ,expr))
  268.  
  269. (##define-macro (check-vector var form expr)
  270.   (define (flat x) (if (pair? x) (cons (car x) (flat (cdr x))) (list x)))
  271.   `(IF-CHECKS
  272.      (IF (##VECTOR? ,var)
  273.        ,expr
  274.        ,(if (list? form)
  275.           `(##TRAP-CHECK-VECTOR ',(car form) ,@(cdr form))
  276.           `(##TRAP-CHECK-VECTOR* ',(car form) ,@(flat (cdr form)))))
  277.      ,expr))
  278.  
  279. (##define-macro (check-procedure var form expr)
  280.   (define (flat x) (if (pair? x) (cons (car x) (flat (cdr x))) (list x)))
  281.   `(IF-CHECKS
  282.      (IF (##PROCEDURE? ,var)
  283.        ,expr
  284.        ,(if (list? form)
  285.           `(##TRAP-CHECK-PROCEDURE ',(car form) ,@(cdr form))
  286.           `(##TRAP-CHECK-PROCEDURE* ',(car form) ,@(flat (cdr form)))))
  287.      ,expr))
  288.  
  289. (##define-macro (check-input-port var form expr)
  290.   (define (flat x) (if (pair? x) (cons (car x) (flat (cdr x))) (list x)))
  291.   `(IF-CHECKS
  292.      (IF (##INPUT-PORT? ,var)
  293.        ,expr
  294.        ,(if (list? form)
  295.           `(##TRAP-CHECK-INPUT-PORT ',(car form) ,@(cdr form))
  296.           `(##TRAP-CHECK-INPUT-PORT* ',(car form) ,@(flat (cdr form)))))
  297.      ,expr))
  298.  
  299. (##define-macro (check-output-port var form expr)
  300.   (define (flat x) (if (pair? x) (cons (car x) (flat (cdr x))) (list x)))
  301.   `(IF-CHECKS
  302.      (IF (##OUTPUT-PORT? ,var)
  303.        ,expr
  304.        ,(if (list? form)
  305.           `(##TRAP-CHECK-OUTPUT-PORT ',(car form) ,@(cdr form))
  306.           `(##TRAP-CHECK-OUTPUT-PORT* ',(car form) ,@(flat (cdr form)))))
  307.      ,expr))
  308.  
  309. (##define-macro (check-open-port var form expr)
  310.   (define (flat x) (if (pair? x) (cons (car x) (flat (cdr x))) (list x)))
  311.   `(IF-CHECKS
  312.      (IF (##NOT (##CLOSED-PORT? ,var))
  313.        ,expr
  314.        ,(if (list? form)
  315.           `(##TRAP-CHECK-OPEN-PORT ',(car form) ,@(cdr form))
  316.           `(##TRAP-CHECK-OPEN-PORT* ',(car form) ,@(flat (cdr form)))))
  317.      ,expr))
  318.  
  319. (##define-macro (check-exact-int-non-neg var form expr)
  320.   (define (flat x) (if (pair? x) (cons (car x) (flat (cdr x))) (list x)))
  321.   `(IF-CHECKS
  322.      (IF (##FIXNUM? ,var)
  323.        (IF (##NOT (##FIXNUM.< ,var 0))
  324.          ,expr
  325.          ,(if (list? form)
  326.             `(##TRAP-CHECK-RANGE ',(car form) ,@(cdr form))
  327.             `(##TRAP-CHECK-RANGE* ',(car form) ,@(flat (cdr form)))))
  328.        (IF (##BIGNUM? ,var)
  329.          ,(if (list? form)
  330.             `(##TRAP-CHECK-RANGE ',(car form) ,@(cdr form))
  331.             `(##TRAP-CHECK-RANGE* ',(car form) ,@(flat (cdr form))))
  332.          ,(if (list? form)
  333.             `(##TRAP-CHECK-EXACT-INT ',(car form) ,@(cdr form))
  334.             `(##TRAP-CHECK-EXACT-INT* ',(car form) ,@(flat (cdr form))))))
  335.      ,expr))
  336.  
  337. (##define-macro (check-exact-int-range var lo hi form expr)
  338.   (define (flat x) (if (pair? x) (cons (car x) (flat (cdr x))) (list x)))
  339.   `(IF-CHECKS
  340.      (IF (##FIXNUM? ,var)
  341.        (IF (##NOT (##FIXNUM.< ,var ,lo))
  342.          (IF (##FIXNUM.< ,var ,hi)
  343.            ,expr
  344.            ,(if (list? form)
  345.               `(##TRAP-CHECK-RANGE ',(car form) ,@(cdr form))
  346.               `(##TRAP-CHECK-RANGE* ',(car form) ,@(flat (cdr form)))))
  347.          ,(if (list? form)
  348.             `(##TRAP-CHECK-RANGE ',(car form) ,@(cdr form))
  349.             `(##TRAP-CHECK-RANGE* ',(car form) ,@(flat (cdr form)))))
  350.        (IF (##BIGNUM? ,var)
  351.          ,(if (list? form)
  352.             `(##TRAP-CHECK-RANGE ',(car form) ,@(cdr form))
  353.             `(##TRAP-CHECK-RANGE* ',(car form) ,@(flat (cdr form))))
  354.          ,(if (list? form)
  355.             `(##TRAP-CHECK-EXACT-INT ',(car form) ,@(cdr form))
  356.             `(##TRAP-CHECK-EXACT-INT* ',(car form) ,@(flat (cdr form))))))
  357.      ,expr))
  358.  
  359. (##define-macro (check-exact-int-range-incl var lo hi form expr)
  360.   (define (flat x) (if (pair? x) (cons (car x) (flat (cdr x))) (list x)))
  361.   `(IF-CHECKS
  362.      (IF (##FIXNUM? ,var)
  363.        (IF (##NOT (##FIXNUM.< ,var ,lo))
  364.          (IF (##NOT (##FIXNUM.< ,hi ,var))
  365.            ,expr
  366.            ,(if (list? form)
  367.               `(##TRAP-CHECK-RANGE ',(car form) ,@(cdr form))
  368.               `(##TRAP-CHECK-RANGE* ',(car form) ,@(flat (cdr form)))))
  369.          ,(if (list? form)
  370.             `(##TRAP-CHECK-RANGE ',(car form) ,@(cdr form))
  371.             `(##TRAP-CHECK-RANGE* ',(car form) ,@(flat (cdr form)))))
  372.        (IF (##BIGNUM? ,var)
  373.          ,(if (list? form)
  374.             `(##TRAP-CHECK-RANGE ',(car form) ,@(cdr form))
  375.             `(##TRAP-CHECK-RANGE* ',(car form) ,@(flat (cdr form))))
  376.          ,(if (list? form)
  377.             `(##TRAP-CHECK-EXACT-INT ',(car form) ,@(cdr form))
  378.             `(##TRAP-CHECK-EXACT-INT* ',(car form) ,@(flat (cdr form))))))
  379.      ,expr))
  380.  
  381. (##define-macro (define-nary0 form no-args one-arg two-args touching)
  382.   (let ((name   (car form))
  383.         (param1 (cadr form))
  384.         (param2 (caddr form)))
  385.     `(DEFINE (,name (,param1) (,param2) . OTHERS)
  386.        (IF (##UNASSIGNED? ,param1)
  387.          ,no-args
  388.          (,touching (,param1)
  389.            (IF (##UNASSIGNED? ,param2)
  390.              ,one-arg
  391.              (,touching (,param2)
  392.                (IF (##NOT (##PAIR? OTHERS))
  393.                  ,two-args
  394.                  (LET LOOP ((,param1 ,two-args) (OTHERS OTHERS))
  395.                    (IF (##PAIR? OTHERS)
  396.                      (LET ((,param2 (##CAR OTHERS)))
  397.                        (,touching (,param2)
  398.                          (LOOP ,two-args (##CDR OTHERS))))
  399.                      ,param1))))))))))
  400.  
  401. (##define-macro (define-nary1 form one-arg two-args touching)
  402.   (let ((name   (car form))
  403.         (param1 (cadr form))
  404.         (param2 (caddr form)))
  405.     `(DEFINE (,name ,param1 (,param2) . OTHERS)
  406.        (,touching (,param1)
  407.          (IF (##UNASSIGNED? ,param2)
  408.            ,one-arg
  409.            (,touching (,param2)
  410.              (IF (##NOT (##PAIR? OTHERS))
  411.                ,two-args
  412.                (LET LOOP ((,param1 ,two-args) (OTHERS OTHERS))
  413.                  (IF (##PAIR? OTHERS)
  414.                    (LET ((,param2 (##CAR OTHERS)))
  415.                      (,touching (,param2)
  416.                        (LOOP ,two-args (##CDR OTHERS))))
  417.                    ,param1)))))))))
  418.  
  419. (##define-macro (define-nary0-boolean form two-args checking touching)
  420.   (let ((name   (car form))
  421.         (param1 (cadr form))
  422.         (param2 (caddr form)))
  423.     `(DEFINE (,name (,param1) (,param2) . OTHERS)
  424.        (IF (##UNASSIGNED? ,param1)
  425.          #T
  426.          (,touching (,param1)
  427.            (IF (##UNASSIGNED? ,param2)
  428.              #T
  429.              (,touching (,param2)
  430.                (,checking ,param1 (,name ,param1 ,param2 . OTHERS)
  431.                  (,checking ,param2 (,name ,param1 ,param2 . OTHERS)
  432.                    (IF (##NOT (##PAIR? OTHERS))
  433.                      ,two-args
  434.                      (AND ,two-args
  435.                           (LET ((TEMP1 ,param1) (TEMP2 ,param2))
  436.                             (LET LOOP ((,param1 ,param2) (TEMP3 OTHERS))
  437.                               (IF (##PAIR? TEMP3)
  438.                                 (LET ((,param2 (##CAR TEMP3)))
  439.                                   (,touching (,param2)
  440.                                     (,checking ,param2 (,name TEMP1 TEMP2 . OTHERS)
  441.                                       (AND ,two-args
  442.                                            (LOOP ,param2 (##CDR TEMP3))))))
  443.                                 #T))))))))))))))
  444.  
  445. ;------------------------------------------------------------------------------
  446.