defproc.scm

(include "~~lib/_gambit#.scm")

(define-syntax primitive
  (lambda (src)

    (define (err)
      (##raise-expression-parsing-exception
       'ill-formed-special-form
       src
       (##source-strip (##car (##source-strip src)))))

    (define (prim sym)
      (##string->symbol
       (##string-append "##" (##symbol->string sym))))

    (##deconstruct-call
     src
     2
     (lambda (arg-src)
       (let ((arg (##desourcify arg-src)))
         (cond ((##symbol? arg)
                (prim arg))
               ((##pair? arg)
                (let ((name (##desourcify (##car arg))))
                  (if (##symbol? name)
                      (##cons (prim name) (##cdr arg))
                      (err))))
               (else
                (err))))))))
    
(define-syntax define-procedure
  (lambda (src)

    (define (err)
      (##raise-expression-parsing-exception
       'ill-formed-special-form
       src
       (##source-strip (##car (##source-strip src)))))

    (define (expand src)
      (##deconstruct-call
       src
       -2
       (lambda (pattern-src . body)
         (let* ((pattern (##source-strip pattern-src))
                (name (and (##pair? pattern) (##source-strip (##car pattern)))))
           (if (##not (##symbol? name))
               (##raise-expression-parsing-exception
                'ill-formed-special-form
                src
                (##source-strip (##car (##source-strip src))))
               (parse-parameters name body (##cdr pattern)))))))

    (define (parse-parameters name body params)
      (let loop ((lst params)
                 (rev-req '())
                 (rev-opt '()))
        (cond ((##null? lst)
               (process-parameters name
                                   body
                                   (##reverse rev-req)
                                   (##reverse rev-opt)
                                   '()))
              ((##pair? lst)
               (let* ((param-src (##car lst))
                      (param (##source-strip param-src)))
                 (cond ((and (##null? rev-opt) (##symbol? param))
                        (loop (##cdr lst)
                              (##cons (##vector param '(object))
                                      rev-req)
                              rev-opt))
                       ((##pair? param)
                        (let ((len (##proper-length param)))
                          (if (or (and (##eqv? len 2) (##null? rev-opt))
                                  (##eqv? len 3))
                              (let* ((var-src (##car param))
                                     (var (##source-strip var-src))
                                     (type-src (##cadr param))
                                     (type (##source-strip type-src))
                                     (check
                                      (cond ((##symbol? type)
                                             (##list type))
                                            ((and (##pair? type)
                                                  (##symbol?
                                                   (##source-strip (##car type))))
                                             (##cons (##source-strip (##car type))
                                                     (##cdr type)))
                                            (else
                                             #f))))
                                (cond ((##not check)
                                       (err))
                                      ((##eqv? len 3)
                                       (let ((default-src (##caddr param)))
                                         (loop (##cdr lst)
                                               rev-req
                                               (##cons (##vector var
                                                                 check
                                                                 default-src)
                                                       rev-opt))))
                                      (else
                                       (loop (##cdr lst)
                                             (##cons (##vector var
                                                               check)
                                                     rev-req)
                                             rev-opt))))
                              (err))))
                       (else
                        (err)))))
              (else
               (let ((rest-param (##source-strip lst)))
                 (if (##symbol? rest-param)
                     (process-parameters name
                                         body
                                         (##reverse rev-req)
                                         (##reverse rev-opt)
                                         rest-param)
                     (err)))))))

    (define (var-name param)
      (##vector-ref param 0))

    (define (var-check param)
      (##vector-ref param 1))

    (define (default param)
      (##vector-ref param 2))

    (define (optional? param)
      (##fx= 3 (##vector-length param)))

    (define (force? param)
      (##not (##equal? (var-check param) '(object))))

    (define (append-sym sym1 sym2)
      (##string->symbol
       (##string-append (##symbol->string sym1)
                        (##symbol->string sym2))))

    (define (param-name param)
      (if (optional? param)
          (append-sym '%opt. (var-name param))
          (var-name param)))

    (define (process-parameters name body req-params opt-params rest-param)
      (let ((req-opt-params
             (##append req-params opt-params))
            (param-list
             (##append
              (##map param-name req-params)
              (if (##null? opt-params)
                  rest-param
                  (##cons '#!optional
                          (##append
                           (##map (lambda (param)
                                    `(,(param-name param)
                                      (macro-absent-obj)))
                                  opt-params)
                           rest-param))))))

        (define (gen-force expr)
          (let ((force-params
                 (##append-lists
                  (##map (lambda (param)
                           (if (force? param) (##list (param-name param)) '()))
                         req-opt-params))))
            (if (##null? force-params)
                expr
                `(macro-force-vars ,force-params ,expr))))

        (define (gen-default param expr)
          (if (optional? param)
              (let ((def-expr (default param)))
                `(##let ((,(var-name param)
                          ,(if (##equal? (##desourcify def-expr)
                                         '(macro-absent-obj))
                               (param-name param)
                               `(##if (##eq? ,(param-name param)
                                             (macro-absent-obj))
                                      ,def-expr
                                      ,(param-name param)))))
                        ,expr))
              expr))

        (define (gen-check param arg-num expr)
          (let ((check (var-check param)))
            (if (or (##equal? check '(object))
                    (##equal? check '(strict-object)))
                expr
                `(,(append-sym 'macro-check- (##car check))
                  ,(var-name param)
                  ,arg-num
                  ,@(##cdr check)
                  (,name ,@(##append (##map param-name req-opt-params) rest-param))
                  ,expr))))

        (define (gen-defaults-and-checks params arg-num expr)
          (if (##null? params)
              expr
              (let ((param (##car params)))
                (gen-default param
                             (gen-check param
                                        arg-num
                                        (gen-defaults-and-checks
                                         (##cdr params)
                                         (##fx+ arg-num 1)
                                         expr))))))

        (let ((expansion
               `(define ,name
                  (lambda ,param-list
                    ,(gen-force
                      (gen-defaults-and-checks
                       req-opt-params
                       1
                       `(begin ,@body)))))))
          (pp expansion)
          expansion)))

    (expand src)))


;;; tests:

(define-procedure (CONS (x object) (y object))
  (primitive (cons x y)))

(define-procedure (MAKE-VECTOR (len index) (init object 0))
  (primitive (make-vector len init)))

(define-procedure (IOTA (count index)
                        (start number 0)
                        (step  number 1))
  (primitive (iota count start step)))

(define-procedure (VECTOR-REF (v vector)
                              (i (index-range 0 (vector-length v))))
  (primitive (vector-ref v i)))

(define-procedure (VECTOR-SET! (v vector)
                               (i (index-range 0 (vector-length v)))
                               (x object))
  (primitive (vector-set! v i x)))

(define-procedure (U8VECTOR-REF (v u8vector)
                                (i (index-range 0 (u8vector-length v))))
  (primitive (u8vector-ref v i)))

(define-procedure (U8VECTOR-SET! (v u8vector)
                                 (i (index-range 0 (u8vector-length v)))
                                 (x exact-unsigned-int8))
  (primitive (u8vector-set! v i x)))

(define-procedure (STRING->UTF8
                   (str   string)
                   (start (index-range-incl 0 (string-length str))
                          0)
                   (end   (index-range-incl start (string-length str))
                          (string-length str)))
  (primitive (string->utf8 str start end)))

(STRING->UTF8 "abcd" 5)
;; raises exception:
;; *** ERROR IN "defproc.scm"@261.1 -- (Argument 2) Out of range
;; (STRING->UTF8 "abcd" 5)