;;;; tinyclos-inlines.scm

;; Aliases for some non-obvious sys routines

(define-inline (%unspecified? x) (##core#inline "C_undefinedp" x))

(define-inline (%unbound? x) (eq? x (##sys#slot '##sys#arbitrary-unbound-symbol 0)))

(define-inline (%string-length s) (##sys#size s))

(define-inline (%car p) (##sys#slot p 0))
(define-inline (%cdr p) (##sys#slot p 1))
(define-inline (%cadr p) (%car (%cdr p)))
(define-inline (%cddr p) (%cdr (%cdr p)))
(define-inline (%set-car! p y) (##sys#setslot p 0 y))
(define-inline (%set-cdr! p y) (##sys#setslot p 1 y))

(define-inline (%stream-port x) (and (port? x) (eq? 'stream (##sys#slot x 7))))
(define-inline (%custom-port x) (and (port? x) (eq? 'custom (##sys#slot x 7))))
(define-inline (%string-port x) (and (port? x) (eq? 'string (##sys#slot x 7))))
(define-inline (%tcp-port x) (and (port? x) (eq? 'tcp (##sys#slot x 7))))

(define-inline (%vector-ref v i) (##sys#slot v i))
(define-inline (%vector-set! v i x) (##sys#setslot v i x))
(define-inline (%vector-length v) (##sys#size v))
(define-inline (%vector-become-structure! v) (##core#inline "C_vector_to_structure" v))
(define-inline (%vector-become-closure! v) (##core#inline "C_vector_to_closure" v))

; (%make-structure+ tag extra-fields-count fixed-field-initial-value ...)
; this is a common pattern
; assume compiler will constant-fold
; note that the tag is an identifier, quoted for actual tag, also used as the
; temp variable

(define-syntax %make-structure+
  (syntax-rules ()

    ((_ "aux" () ?count ?initial ?struc ?fixed (?body ...))
      (let ((?struc (make-vector (+ ?count ?fixed) ?initial)))
        (%vector-become-structure! ?struc)
        ?body ...
        ?struc ) )

    ((_ "aux" (?field ?rest ...) ?count ?initial ?struc ?fixed (?body ...))
      (%make-structure+ "aux"
        (?rest ...)
        ?count ?initial ?struc (fx+ ?fixed 1)
        ((%structure-set! ?struc ?fixed ?field) ?body ...)) )

    ((_ ?tag (?count ?initial) ?field ...)
      (%make-structure+ "aux"
        ('?tag ?field ...)
        ?count ?initial ?tag 0
        ()) )

    ((_ ?tag ?count ?field ...)
      (%make-structure+ ?tag (?count #f) ?field ...) ) ) )

(define-syntax %structure?
  (syntax-rules ()
    ((_ ?x)     (##sys#generic-structure? ?x))
    ((_ ?x ?t)  (##sys#structure? ?x ?t))))

(define-inline (%structure-ref r i) (##sys#slot r i))
(define-inline (%structure-set! r i x) (##sys#setslot r i x))
(define-inline (%structure-length r) (##sys#size r))
(define-inline (%structure-tag r) (##sys#slot r 0))

(define-inline (%closure-ref c i) (##sys#slot c i))
(define-inline (%closure-length c) (##sys#size c))

(define-inline (%special-copy-address! from to) (##core#inline "C_copy_pointer" from to))

(define-inline (%pointer? x) (##core#inline "C_pointerp" x)) ;not anypointer
(define-inline (%null-pointer? p) (##sys#null-pointer? p))

(define-inline (%tagged-pointer? x) (##core#inline "C_taggedpointerp" x))
(define-inline (%tagged-pointer-data p) (##sys#slot p 1))

(define-inline (%swig-pointer? x) (##core#inline "C_swigpointerp" x))

(define-inline (%locative? x) (##core#inline "C_locativep" x))

(define-inline (%random-fixnum x) (##core#inline "C_random_fixnum" x))

; Error messages will not mutate!

(define-syntax %error
  (syntax-rules ()
    ((_ ?msg ?arg0 ...) (##sys#error (##core#immutable '?msg) ?arg0 ...))))

(define-syntax %error@
  (syntax-rules ()
    ((_ ?loc ?msg ?arg0 ...) (##sys#error ?loc (##core#immutable '?msg) ?arg0 ...))))

;;

(define-inline (delete!/1 test lst)
  (let loop ((cpair lst) (ppair #f))
    (cond ((null? cpair) lst )
          ((test (%car cpair))
            (if ppair
                (begin (%set-cdr! ppair (%cdr cpair)) lst)
                (%cdr cpair)) )
          (else (loop (%cdr cpair) cpair) ) ) ) )

(define-inline (any/1 test lst)
  (let loop ((lst lst))
    (and (not (null? lst))
         (if (test (%car lst))
             (%car lst)
             (loop (%cdr lst)) ) ) ) )

(define-inline (every/1 test lst)
  (let loop ((lst lst))
    (or (null? lst)
        (and (test (%car lst))
             (loop (%cdr lst)) ) ) ) )

;;

(define-syntax ->boolean
  (syntax-rules ()
    ((_ ?expr) (and ?expr #t)) ) )

; more descriptive than a gensym
(define-syntax define-unique-object
  (syntax-rules ()
    ((_ ?name) (define ?name (##sys#list->vector `('?name)))) ) )