home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / sources.lha / sources / comp / primops / open.t < prev    next >
Encoding:
Text File  |  1988-02-05  |  7.4 KB  |  257 lines
  1. (herald open (env tsys))
  2.  
  3. ;;; Copyright (c) 1985 Yale University
  4. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  5. ;;; This material was developed by the T Project at the Yale University Computer 
  6. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  7. ;;; and to use it for any purpose is granted, subject to the following restric-
  8. ;;; tions and understandings.
  9. ;;; 1. Any copy made of this software must include this copyright notice in full.
  10. ;;; 2. Users of this software agree to make their best efforts (a) to return
  11. ;;;    to the T Project at Yale any improvements or extensions that they make,
  12. ;;;    so that these may be included in future releases; and (b) to inform
  13. ;;;    the T Project of noteworthy uses of this software.
  14. ;;; 3. All materials developed as a consequence of the use of this software
  15. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  16. ;;;    of acknowledging credit in academic research.
  17. ;;; 4. Yale has made no warrantee or representation that the operation of
  18. ;;;    this software will be error-free, and Yale is under no obligation to
  19. ;;;    provide any services, by way of maintenance, update, or otherwise.
  20. ;;; 5. In conjunction with products arising from the use of this material,
  21. ;;;    there shall be no use of the name of the Yale University nor of any
  22. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  23. ;;;    without prior written consent from Yale in each case.
  24. ;;;
  25.  
  26. ;;; The following variables are free in this file: 
  27. ;;; ( FIXNUM-NEGATE CHOPY MEM EOF NO-MORE-COND-CLAUSES NTH )
  28.  
  29. ;;;; Standard constant procedures
  30.  
  31. ;;; Open-coded routines, defined as constant procedures.
  32.  
  33. ;;; System constants
  34.  
  35. (define-constant t    '#t)
  36. (define-constant else '#t)
  37. (define-constant nil  '#f)
  38.  
  39. ;++ move this stuff
  40. (define-constant null-char #\null)
  41. (define-constant number-of-char-codes 256)
  42. (define-constant string-length-limit 8388607)   ;inclusive limit (2^23 - 1)
  43.  
  44. ;;; Boolean stuff
  45.  
  46. (define-constant (not x) (if x nil t))
  47. (define-constant (false? x) (if x nil t))
  48.  
  49. (define-constant (boolean? x) (or (eq? x t) (eq? x nil)))
  50.  
  51. ;;; Combinator stuff
  52.  
  53. (define-constant (always v) (lambda x (ignore x) v))
  54.  
  55. (define-constant (proj0 x . rest) (ignore rest) x)
  56. (define-constant (proj1 x y . rest) (ignore rest x) y)
  57. (define-constant (proj2 x y z . rest) (ignore rest x y) z)
  58. (define-constant (proj3 x y z w . rest) (ignore rest x y z) w)
  59.  
  60. (define-constant (projn n) (lambda arglist (nth arglist n)))
  61.  
  62. (define-constant (identity x) x)
  63.  
  64. ;;; Macro support for compiler
  65.  
  66. (define-constant (cond-=>-aux p f a) (if p ((f) p) (a)))
  67.  
  68. (define-constant (or-aux p r) (if p p (r)))
  69.  
  70. ;;; Used by the compiler for n-ary LETs
  71.  
  72. (define (%list . l) l)  ; Not DEFINE-CONSTANT (that's the whole point).
  73.  
  74. ;;; Type checking
  75.  
  76. (define-constant (enforce type obj)
  77.   (if (type obj) obj (*enforce type obj)))
  78.  
  79. (define-constant (check-arg type obj where)
  80.   (ignore where)
  81.   (if (type obj) obj (*enforce type obj)))
  82.  
  83. ;;; Various predicates
  84.  
  85. (define-constant (null-list? x)
  86.   (cond ((null? x) t)
  87.         ((list? x) nil)
  88.         (else (undefined-effect "NULL-LIST? got an atom"))))
  89.  
  90. (define-constant (eof? x)
  91.   (eq? x eof))
  92.  
  93. (define-constant (newline? c) (eq? c #\newline))
  94.  
  95. (define-constant (mem? pred obj list)
  96.   (if (mem pred obj list) t nil))
  97.  
  98. (define-constant (memq? obj list)
  99.   (if (memq obj list) t nil))
  100.  
  101. (define-constant (neq? x y) (not (eq? x y)))
  102.  
  103. (define-constant (nonnegative-fixnum? x)
  104.   (and (fixnum? x) (fixnum-not-negative? x)))
  105.  
  106. ;;; Totally random stuff
  107.  
  108. (define-constant (env-lookup env identifier local? create?)
  109.   (env identifier local? create?))
  110.  
  111. (define-constant (cons x y)
  112.   (let ((p (%make-pair)))
  113.     (set (car p) x)
  114.     (set (cdr p) y)
  115.     p))
  116.  
  117. ;;; Making closed forms check their arguments
  118.  
  119. (define-local-syntax (define-safe form . stuff)
  120.   (let ((name (if (atom? form) form (car form))))
  121.     `(block
  122.        (define-constant ,form . ,stuff)
  123.        (declare type-safe-closed-form ,name))))
  124.  
  125. (define-safe (vset vec i val)
  126.   (set (vector-elt vec i) val))
  127.  
  128. ;;; String stuff
  129.  
  130. (define-safe (non-empty-string? x)
  131.   (and (string? x) (not (string-empty? x))))
  132.                               
  133. (define-safe (string-empty? x)
  134.   (fixnum-equal? (string-length x) 0))
  135.  
  136. (define-safe (string-tail s)
  137.   (string-tail! (chopy s)))
  138.                           
  139. (define-safe (string-tail! string)
  140.   (string-nthtail! string 1))
  141.  
  142. (define-safe (string-nthtail s n)
  143.   (string-nthtail! (chopy s) n))
  144.       
  145. (define-safe (string-nthtail! s n)
  146.   (%chdr s n)
  147.   s)
  148.  
  149. ;;; The LETs in STRING-ELT forces STRING-TEXT to be done before MREF-INTEGER.
  150. ;;; Then in the type-safe version the STRING? test is done on X before the
  151. ;;; MREF-INTEGER call.  The problem is that MREF-INTEGER has no prefered type.
  152.  
  153. (define-safe string-elt
  154.   (object (lambda (x i)
  155.             (let ((s (string-text x)))
  156.               (text-elt s (fixnum-add (mref-integer x 4) i))))
  157.     ((setter self)
  158.      (lambda (x i v)
  159.        (let ((s (string-text x)))
  160.          (set (text-elt s (fixnum-add (mref-integer x 4) i))
  161.               v))))))
  162.  
  163. (define-safe string-head 
  164.   (object (lambda (x) (string-elt x 0))
  165.     ((setter self)
  166.      (lambda (x v)
  167.        (set (string-elt x 0) v)))))
  168.                                  
  169. (define-constant string-offset
  170.   (object (lambda (s)
  171.             (let ((s (enforce string? s)))
  172.               (mref-integer s 4)))
  173.     ((setter self)
  174.      (lambda (self i)
  175.        (let ((s (enforce string? self))
  176.              (i (enforce fixnum? i)))
  177.          (set (mref-integer s 4) i))))
  178.     ((identification self) 'string-offset)))
  179.  
  180. (define-safe (max-string-length s)
  181.   (text-length (string-text s)))
  182.                 
  183. ;;; Fixnum stuff
  184.  
  185. (define-safe (fixnum-greater? x y)
  186.   (fixnum-less? y x))
  187.  
  188. (define-safe (fixnum-not-equal? x y)
  189.   (not (fixnum-equal? x y)))
  190.  
  191. (define-safe (fixnum-not-less? x y)
  192.   (not (fixnum-less? x y)))
  193.  
  194. (define-safe (fixnum-not-greater? x y)
  195.   (not (fixnum-less? y x)))
  196.  
  197. (define-safe (fixnum-abs n)
  198.   (if (fixnum-less? n 0) (fixnum-negate n) n))
  199.  
  200. (define-safe (fixnum-min x y)
  201.   (if (fixnum-less? x y) x y))
  202.  
  203. (define-safe (fixnum-max x y)
  204.   (if (fixnum-greater? x y) x y))
  205.  
  206. (define-safe (fixnum-positive?     x) (fixnum-greater?     x 0))
  207. (define-safe (fixnum-negative?     x) (fixnum-less?        x 0))
  208. (define-safe (fixnum-zero?         x) (fixnum-equal?       x 0))
  209. (define-safe (fixnum-not-positive? x) (fixnum-not-greater? x 0))
  210. (define-safe (fixnum-not-negative? x) (fixnum-not-less?    x 0))
  211. (define-safe (fixnum-not-zero?     x) (fixnum-not-equal?   x 0))
  212. (define-safe (fixnum-add1          x) (fixnum-add          x 1))
  213. (define-safe (fixnum-subtract1     x) (fixnum-subtract     x 1))
  214.                             
  215. (define-safe (fixnum-odd? x)
  216.   (bit-test x 0))
  217.  
  218. (define-safe (fixnum-even? x)
  219.   (not (fixnum-odd? x)))
  220.  
  221. ;;; Character comparison stuff
  222.  
  223. (define-safe (char> x y)
  224.   (char< y x))
  225.  
  226. (define-safe (charn= x y)
  227.   (not (char= x y)))
  228.  
  229. (define-safe (char>= x y)
  230.   (not (char< x y)))
  231.  
  232. (define-safe (char<= x y)
  233.   (not (char< y x)))
  234.  
  235.  
  236. ;;; Weaks
  237.  
  238. (define-integrable (weak-semaphore-set? weak)
  239.   (not (alt-bit-set? weak)))
  240.  
  241. (define-integrable (set-weak-semaphore weak)
  242.   (cond ((weak-semaphore-set? weak)
  243.          (error "simultaneous access on weak ~S" weak))
  244.         (else
  245.          (clear-alt-bit! weak))))
  246.  
  247. (define-integrable (clear-weak-semaphore weak)
  248.   (set-alt-bit! weak)
  249.   0)
  250.  
  251. (define-constant (test-and-set-semaphore weak)
  252.   (defer-interrupts (cond ((weak-semaphore-set? weak)
  253.                            t)
  254.                           (else
  255.                            (clear-alt-bit! weak)
  256.                            nil))))
  257.