lolevel.scm

Scheme跨平台编译器

(define list->byte-vector		; DEPRECATED
    (lambda (lst)
      (##sys#check-list lst 'list->byte-vector)
      (let* ([n (length lst)]
	     [v (make-byte-vector n)] )
	(do ([p lst (##sys#slot p 1)]
	     [i 0 (fx+ i 1)] )
	    ((eq? p '()) v)
	  (if (pair? p)
	      (let ([b (##sys#slot p 0)])
		(##sys#check-exact b 'list->byte-vector)
		(##sys#setbyte v i b) )
	      (##sys#not-a-proper-list-error lst) ) ) ) ) )

(define string->byte-vector string->blob) ; DEPRECATED

(define byte-vector->string blob->string) ; DEPRECATED

(define byte-vector-length blob-size) ; DEPRECATED

(define-foreign-variable _c_header_size_mask int "C_HEADER_SIZE_MASK")

(let ([malloc
       (foreign-lambda* scheme-object ((int size))
	 "char *bv;
           if((bv = (char *)C_malloc(size + 3 + sizeof(C_header))) == NULL) return(C_SCHEME_FALSE);
           bv = (char *)C_align((C_word)bv);
           ((C_SCHEME_BLOCK *)bv)->header = C_BYTEVECTOR_TYPE | size;
           return((C_word)bv);") ] )
  (define (make size init alloc loc)
    (##sys#check-exact size loc)
    (if (fx> size _c_header_size_mask)
	(##sys#signal-hook #:bounds-error loc "out of range" size _c_header_size_mask)
	(let ([bv (alloc size)])
	  (cond [bv
		 (when (pair? init) (byte-vector-fill! bv (##sys#slot init 0)))
		 bv]
		[else (##sys#signal-hook #:runtime-error "can not allocate statically allocated bytevector" size)] ) ) ) )
  (set! make-static-byte-vector 	; DEPRECATED
    (lambda (size . init) (make size init malloc 'make-static-byte-vector))))

(define static-byte-vector->pointer 		; DEPRECATED
  (lambda (bv)
    (##sys#check-byte-vector bv 'static-byte-vector->pointer)
    (if (##core#inline "C_permanentp" bv)
	(let ([p (##sys#make-pointer)])
	  (##core#inline "C_pointer_to_block" p bv)
	  p)
	(##sys#error 'static-byte-vector->pointer "can not coerce non-static blob" bv) ) ) )

(define (byte-vector-move! src src-start src-end dst dst-start) ; DEPRECATED
  (let ((from (make-locative src src-start))
        (to   (make-locative dst dst-start)) )
    (move-memory! from to (- src-end src-start)) ) )

(define (byte-vector-append . vectors)		; DEPRECATED
  (define (append-rest-at i vectors)
    (if (pair? vectors)
        (let* ((src (car vectors))
               (len (byte-vector-length src))
               (dst (append-rest-at (+ i len) (cdr vectors))) )
          (byte-vector-move! src 0 len dst i)
          dst )
        (make-byte-vector i) ) )
  (append-rest-at 0 vectors) )


;;; Accessors for arbitrary block objects:

(define block-set! ##sys#block-set!)
(define block-ref (getter-with-setter ##sys#block-ref ##sys#block-set!))

(define number-of-slots 
  (lambda (x)
    (when (or (not (##core#inline "C_blockp" x)) 
	      (##core#inline "C_specialp" x)
	      (##core#inline "C_byteblockp" x) )
      (##sys#signal-hook #:type-error 'number-of-slots "slots not accessible" x) )
    (##sys#size x) ) )

(define (number-of-bytes x)
  (cond [(not (##core#inline "C_blockp" x))
	 (##sys#signal-hook #:type-error 'number-of-bytes "can not compute number of bytes of immediate object" x) ]
	[(##core#inline "C_byteblockp" x) (##sys#size x)]
	[else (##core#inline "C_w2b" (##sys#size x))] ) )


;;; Record objects:

(define (make-record-instance type . args)
  (##sys#check-symbol type 'make-record-instance)
  (apply ##sys#make-structure type args) )

(define (record-instance? x)
  (and (##core#inline "C_blockp" x)
       (##core#inline "C_structurep" x) ) )

(define (record->vector x)
  (if (and (not (##sys#immediate? x)) (##sys#generic-structure? x))
      (let* ([n (##sys#size x)]
	     [v (##sys#make-vector n)] )
	(do ([i 0 (fx+ i 1)])
	    ((fx>= i n) v)
	  (##sys#setslot v i (##sys#slot x i)) ) )
      (##sys#signal-hook #:type-error 'record->vector "bad argument type - not a record structure" x) ) )


;;; Copy arbitrary object:

(define (object-copy x)
  (let copy ([x x])
    (cond [(not (##core#inline "C_blockp" x)) x]
	  [(symbol? x) (##sys#intern-symbol (##sys#slot x 1))]
	  [else
	    (let* ([n (##sys#size x)]
		   [words (if (##core#inline "C_byteblockp" x) (##core#inline "C_words" n) n)]
		   [y (##core#inline "C_copy_block" x (##sys#make-vector words))] )
              (unless (or (##core#inline "C_byteblockp" x) (symbol? x))
		(do ([i (if (##core#inline "C_specialp" x) 1 0) (fx+ i 1)])
		    ((fx>= i n))
		  (##sys#setslot y i (copy (##sys#slot y i))) ) )
	      y) ] ) ) )


;;; Evict objects into static memory:

(define-constant evict-table-size 301)

(define (object-evicted? x) (##core#inline "C_permanentp" x))

(define object-evict
    (lambda (x . allocator)
      (let ([allocator 
	     (if (pair? allocator) 
		 (car allocator)
		 (foreign-lambda c-pointer "C_malloc" int) ) ] 
	    [tab (##sys#make-vector evict-table-size '())] )
	(let evict ([x x])
	  (cond [(not (##core#inline "C_blockp" x)) x]
		[(##sys#hash-table-ref tab x)]
		[else
		 (let* ([n (##sys#size x)]
			[bytes (if (##core#inline "C_byteblockp" x) (align-to-word n) (##core#inline "C_bytes" n))]
			[y (##core#inline "C_evict_block" x (allocator (fx+ bytes (##core#inline "C_bytes" 1))))] )
		   (when (symbol? x) (##sys#setislot y 0 (##core#undefined)))
		   (##sys#hash-table-set! tab x y)
		   (unless (##core#inline "C_byteblockp" x)
		     (do ([i (if (or (##core#inline "C_specialp" x) (symbol? x)) 1 0) (fx+ i 1)])
			 ((fx>= i n))
		       ;; Note the use of `##sys#setislot' to avoid an entry in the mutations-table:
		       (##sys#setislot y i (evict (##sys#slot x i))) ) )
		   y) ] ) ) ) ) )

(define object-release
  (lambda (x . releaser)
    (let ((free (if (pair? releaser) 
		    (car releaser) 
		    (foreign-lambda void "C_free" c-pointer) ) ) 
	  (released '()))
      (let release ([x x])
	(cond [(not (##core#inline "C_blockp" x)) x]
	      [(not (##core#inline "C_permanentp" x)) x]
	      ((memq x released) x)
	      [else
	       (let ([n (##sys#size x)])
		 (set! released (cons x released))
		 (unless (##core#inline "C_byteblockp" x)
		   (do ([i (if (##core#inline "C_specialp" x) 1 0) (fx+ i 1)])
		       ((fx>= i n))
		     (release (##sys#slot x i))) )
		 (free (##sys#address->pointer (##core#inline_allocate ("C_block_address" 4) x))) ) ] ) ) ) ) )

(define object-evict-to-location
    (lambda (x ptr . limit)
      (cond-expand
       [(not unsafe)
	(when (not (and (##core#inline "C_blockp" ptr) (##core#inline "C_specialp" ptr)))
	  (##sys#signal-hook #:type-error 'object-evict-to-location "bad argument type - not a pointer" ptr) ) ]
       [else] )
      (let* ([limit
	      (if (pair? limit)
		  (let ([limit (car limit)])
		    (##sys#check-exact limit 'object-evict-to-location)
		    limit)
		  #f) ]
	     [ptr2 (##sys#address->pointer (##sys#pointer->address ptr))]
	     [tab (##sys#make-vector evict-table-size '())]
	     [x2
	      (let evict ([x x])
		(cond [(not (##core#inline "C_blockp" x)) x]
		      [(##sys#hash-table-ref tab x)]
		      [else
		       (let* ([n (##sys#size x)]
			      [bytes 
			       (fx+ (if (##core#inline "C_byteblockp" x) (align-to-word n) (##core#inline "C_bytes" n))
				    (##core#inline "C_bytes" 1) ) ] )
			 (when limit
			   (set! limit (fx- limit bytes))
			   (when (fx< limit 0) 
			     (signal
			      (make-composite-condition
			       (make-property-condition
				'exn 'location 'object-evict-to-location
				'message "can not evict object - limit exceeded" 
				'arguments (list x limit))
			       (make-property-condition 'evict 'limit limit) ) ) ) )
			 (let ([y (##core#inline "C_evict_block" x ptr2)])
			   (when (symbol? x) (##sys#setislot y 0 (##core#undefined)))
			   (##sys#set-pointer-address! ptr2 (+ (##sys#pointer->address ptr2) bytes))
			   (##sys#hash-table-set! tab x y)
			   (unless (##core#inline "C_byteblockp" x)
			     (do ([i (if (or (##core#inline "C_specialp" x) (symbol? x))
					 1
					 0)
				     (fx+ i 1) ] )
				 ((fx>= i n))
			       (##sys#setislot y i (evict (##sys#slot x i))) ) ) ; see above
			   y) ) ] ) ) ] )
	(values x2 ptr2) ) ) )

(define object-size
    (lambda (x)
      (let ([tab (##sys#make-vector evict-table-size '())])
	(let evict ([x x])
	  (cond [(not (##core#inline "C_blockp" x)) 0]
		[(##sys#hash-table-ref tab x) 0]
		[else
		 (let* ([n (##sys#size x)]
			[bytes
			 (fx+ (if (##core#inline "C_byteblockp" x) (align-to-word n) (##core#inline "C_bytes" n))
			      (##core#inline "C_bytes" 1) ) ] )
		   (##sys#hash-table-set! tab x #t)
		   (unless (##core#inline "C_byteblockp" x)
		     (do ([i (if (or (##core#inline "C_specialp" x) (symbol? x))
				 1 
				 0)
			     (fx+ i 1) ] )
			 ((fx>= i n))
		       (set! bytes (fx+ (evict (##sys#slot x i)) bytes)) ) )
		   bytes) ] ) ) ) ) )

(define object-unevict
    (lambda (x #!optional (full #f))
      (define (err x)
	(##sys#signal-hook #:type-error 'object-unevict "can not copy object" x) )
      (let ([tab (##sys#make-vector evict-table-size '())])
	(let copy ([x x])
	  (cond [(not (##core#inline "C_blockp" x)) x]
		[(not (##core#inline "C_permanentp" x)) x]
		[(##sys#hash-table-ref tab x)]
		[(##core#inline "C_byteblockp" x) 
		 (if full
		     (let ([y (##core#inline "C_copy_block" x (##sys#make-string (##sys#size x)))])
		       (##sys#hash-table-set! tab x y)
		       y) 
		     x) ]
		[(symbol? x) 
		 (let ([y (##sys#intern-symbol (##sys#slot x 1))])
		   (##sys#hash-table-set! tab x y)
		   y) ]
		[else
		 (let* ([words (##sys#size x)]
			[y (##core#inline "C_copy_block" x (##sys#make-vector words))] )
		   (##sys#hash-table-set! tab x y)
		   (do ([i (if (##core#inline "C_specialp" x) 1 0) (fx+ i 1)])
		       ((fx>= i words))
		     (##sys#setslot y i (copy (##sys#slot y i))) )
		   y) ] ) ) ) ) )


;;; `become':

(define object-become! 
  (cond-expand
   [unsafe ##sys#become!]
   [else
    (lambda (lst)
      (##sys#check-list lst 'object-become!)
      (let loop ([lst lst])
	(cond [(null? lst)]
	      [(pair? lst)
	       (let ([a (##sys#slot lst 0)])
		 (##sys#check-pair a 'object-become!)
		 (unless (##core#inline "C_blockp" (##sys#slot a 0))
		   (##sys#signal-hook #:type-error 'object-become! "bad argument type - old item is immediate" a) )
		 (unless (##core#inline "C_blockp" (##sys#slot a 1))
		   (##sys#signal-hook #:type-error 'object-become! "bad argument type - new item is immediate" a) )
		 (loop (##sys#slot lst 1)) ) ]
	      [else (##sys#signal-hook #:type-error 'object-become! "bad argument type - not an a-list")] ) )
      (##sys#become! lst) ) ] ) )

(define (mutate-procedure old proc)
  (unless (##core#check (procedure? old))
    (##sys#signal-hook #:type-error 'mutate-procedure "bad argument type - not a procedure" old))
  (let* ((n (##sys#size old))
	 (words (##core#inline "C_words" n))
	 (y (##core#inline "C_copy_block" old (##sys#make-vector words))) )
    (##sys#become! (list (cons old (proc y))))
    y) )


;;; locatives:

(define (make-locative obj . index)
  (##sys#make-locative obj (:optional index 0) #f 'make-locative) )

(define (make-weak-locative obj . index)
  (##sys#make-locative obj (:optional index 0) #t 'make-weak-locative) )

(define (locative-set! x y) (##core#inline "C_i_locative_set" x y))
(define locative-ref (getter-with-setter (##core#primitive "C_locative_ref") locative-set!))
(define (locative->object x) (##core#inline "C_i_locative_to_object" x))
(define (locative? x) (and (##core#inline "C_blockp" x) (##core#inline "C_locativep" x)))


;;; Hooks:

(define ipc-hook-0 #f)			; we need this because `##sys#invalid-procedure-call-hook' may not have free variables.

(define (set-invalid-procedure-call-handler! proc)
  (unless (procedure? proc)
    (##sys#signal-hook #:type-error 'set-invalid-procedure-call-handler! "bad argument type - not a procedure" proc) )
  (set! ipc-hook-0 proc)
  (set! ##sys#invalid-procedure-call-hook 
    (lambda args
      (ipc-hook-0 ##sys#last-invalid-procedure args) ) ) )

(define (unbound-variable-value . val)
  (set! ##sys#unbound-variable-value-hook 
    (and (pair? val)
	 (vector (car val)) ) ) )


;;; Access computed globals:

(define (global-ref sym)
  (##sys#check-symbol sym 'global-ref)
  (##core#inline "C_retrieve" sym) )

(define (global-set! sym x)
  (##sys#check-symbol sym 'global-set!)
  (##sys#setslot sym 0 x) )

(define (global-bound? sym)
  (##sys#check-symbol sym 'global-bound?)
  (##sys#symbol-has-toplevel-binding? sym) )

(define (global-make-unbound! sym)
  (##sys#check-symbol sym 'global-make-unbound!)
  (##sys#setslot sym 0 (##sys#slot '##sys#arbitrary-unbound-symbol 0))
  sym)