;;; bytestructures --- Structured access to bytevector contents.

;; Copyright © 2015, 2016 Taylan Kammer <taylan.kammer@gmail.com>

;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:

;; This is the base of the module, defining the data types and procedures that
;; make up the bytestructures framework.


;;; Code:

;;; Descriptors

(drt <bsd>
     (%mkbsd size align unwrap getter setter meta)
     bsd?
     (size   bsize)
     (align  balign)
     (unwrap bunwrp)
     (getter bgettr)
     (setter bsettr)
     (meta   bmeta))

(define mkbsd
  (clmbda
   ((size align unwrap getter setter)
    (%mkbsd
     size align unwrap getter setter #f))
   ((size align unwrap getter setter meta)
    (%mkbsd
     size align unwrap getter setter meta))))

(define bdsz
  (clmbda
   ((dscr) (bdsz dscr #f #f))
   ((dscr bvec offset)
    (let ((size (bsize dscr)))
      (if (proc? size)
          (size #f bvec offset)
          size)))))

(define (bdsz/s bvec offset dscr)
  (let ((size (bsize dscr)))
    (if (proc? size)
        (size #t bvec offset)
        size)))


;;; Bstrs

(drt <bstr>
     (mkbstr bvec offset dscr)
     bstr?
     (bvec   bsbvec)
     (offset bsofst)
     (dscr   bsdscr))

(define bstr
  (clmbda ((dscr)        (%bstr dscr #f #f))
          ((dscr values) (%bstr dscr #t values))))

(define (%bstr dscr init? values)
  (let ((bvec (mkbvec
               (bdsz dscr))))
    (when init?
      (bspst! bvec 0 dscr values))
    (mkbstr bvec 0 dscr)))

(define (bssize bstr)
  (bdsz (bsdscr bstr)
        (bsbvec bstr)
        (bsofst bstr)))

(dsr (bsunwp <bstr> <indx> ...)
     (let ((bstr <bstr>))
       (let ((bvec   (bsbvec bstr))
             (offset (bsofst bstr))
             (dscr   (bsdscr bstr)))
         (bsunwp bvec offset dscr <indx> ...))))

(defsyn bsnwp*
  (synrul ()
          ((_ <bvec> <ofst> <dscr>)
           (values <bvec> <ofst> <dscr>))
          ((_ <bvec> <ofst> <dscr> <indx> <idxs> ...)
           (let ((bvec <bvec>)
                 (offset <ofst>)
                 (dscr <dscr>))
             (let ((unwrap (bunwrp dscr)))
               (when (not unwrap)
                 (error "cannot" dscr))
               (letvls (((bvec* ofst* dscr*)
                         (unwrap #f bvec offset <indx>)))
                       (bsnwp*
                        bvec* ofst* dscr* <idxs> ...)))))))

(defsyr (bsref <bstr> <indx> ...)
  (letvls (((bvec offset dscr)
            (bsunwp <bstr> <indx> ...)))
          (bspref bvec offset dscr)))

(defsyr (bsref*
         <bvec> <ofst> <dscr> <indx> ...)
  (letvls (((bvec offset dscr)
            (bsnwp*
             <bvec> <ofst> <dscr> <indx> ...)))
          (bspref bvec offset dscr)))

(define (bspref bvec offset dscr)
  (let ((getter (bdgtr dscr)))
    (if getter
        (getter #f bvec offset)
        (mkbstr bvec offset dscr))))

(defsyr (bsst! <bstr> <indx> ... <valu>)
  (letvls (((bvec offset dscr)
            (bsunwp <bstr> <indx> ...)))
          (bsps! bvec offset dscr <valu>)))

(defsyr (bsst!*
         <bvec> <ofst> <dscr> <indx> ... <valu>)
  (letvls (((bvec offset dscr)
            (bsnwp*
             <bvec> <ofst> <dscr> <indx> ...)))
          (bspst! bvec offset dscr <valu>)))

(define (bspst! bvec offset dscr value)
  (let ((setter (bdstr dscr)))
    (if setter
        (setter #f bvec offset value)
        (if (bvec? value)
            (bvecop bvec offset value 0
                    (bdsz
                     dscr bvec offset))
            (error "cannot"
                   value dscr)))))

(define (bsrf/d bstr . indxs)
  (letvls (((bvec offset dscr)
            (bsunwp bstr)))
          (let loop ((bvec bvec)
                     (offset offset)
                     (dscr dscr)
                     (indxs indxs))
            (if (null? indxs)
                (bspref bvec offset dscr)
                (letvls (((bvec* ofst* dscr*)
                          (bsnwp*
                           bvec offset dscr (car indxs))))
                        (loop bvec*
                              ofst*
                              dscr*
                              (cdr indxs)))))))

(define (bst!/d bstr . args)
  (letvls (((bvec offset dscr)
            (bsunwp bstr)))
          (let loop ((bvec bvec)
                     (offset offset)
                     (dscr dscr)
                     (args args))
            (if (null? (cdr args))
                (bset! bvec offset dscr (car args))
                (letvls (((bvec* ofst* dscr*)
                          (bsnwp*
                           bvec offset dscr (car args))))
                        (loop bvec*
                              ofst*
                              dscr*
                              (cdr args)))))))

(defsyn
  bnwp/s
  bref/s
  bset/s
  dba)

(cexp
 (guile  (incfp "bstrs"))
 (syncas (incld "base"))
 (else))

;;; base.scm ends here