source: project/release/5/slib-prec/trunk/slib-prec.scm @ 38563

;;;; slib-prec.scm  -*-scheme-*-
;;;; Kon Lovett, Apr '20
;;;; Kon Lovett, Apr '18

;; Issues
;;
;; - needs a "surface notation"

(module slib-prec

(;export
  ;
  syntax-end!                 ; (set! *syn-defs* '())   => (syntax-end!)
  syntax-begin!               ; (set! *syn-def* ...)    => (syntax-begin! ...)
  syntax-current              ; *syn-def*               => (syntax-current)
  syntax-ignore-whitespace    ; *syn-ignore-whitespace* => (syntax-ignore-whitespace)
  ;
  char-code-limit
  tok:decimal-digits
  tok:upper-case
  tok:lower-case
  tok:whitespaces
  tok:char-group
  tok:read-char
  ;
  prec:define-grammar
  prec:parse
  prec:make-led
  prec:make-nud
  prec:delim
  prec:nofix
  prec:prefix
  prec:infix
  prec:infixr
  prec:nary
  prec:postfix
  prec:prestfix
  prec:commentfix
  prec:matchfix
  prec:inmatchfix)

(import scheme)
(import (chicken base))

;;;

(cond-expand
  (utf8
    (import (rename scheme
        (char-whitespace? scheme:char-whitespace?)
        (char-alphabetic? scheme:char-alphabetic?)
        (char-upper-case? scheme:char-upper-case?)
        (char-lower-case? scheme:char-lower-case?)
        (char-numeric? scheme:char-numeric?)))
    (import (chicken foreign))
    (import utf8)
    (import utf8-srfi-13)
    (import utf8-case-map)
    (import utf8-srfi-14)
    (import unicode-char-sets)

    ;; UTF-8 char predicates

    (define charset-alphabetic?)
    (define charset-upper-case?)
    (define charset-lower-case?)
    (define charset-whitespace?)
    (define charset-numeric?)
    (define charset-hex-numeric?)
    (let ()
      (define ((charset-predicate cs) ch) (char-set-contains? cs ch))
      (set! charset-alphabetic? (charset-predicate char-set:alphabetic))
      (set! charset-upper-case? (charset-predicate char-set:uppercase))
      (set! charset-lower-case? (charset-predicate char-set:lowercase))
      (set! charset-whitespace? (charset-predicate char-set:white-space))
      (set! charset-numeric? (charset-predicate char-set:digit))
      (set! charset-hex-numeric? (charset-predicate char-set:hex-digit)) )
    (define char-hex-numeric? charset-hex-numeric?)

    ;Character range is that of a UTF-8 codepoint, not representable range
    (define char-code-limit (foreign-value "C_CHAR_BIT_MASK" unsigned-int)))
  (else
    (import srfi-13)
    (import srfi-14)
    ; "Extended" ASCII
    (define char-code-limit 256)) )

;; SLIB Code

(import (only (chicken port) call-with-output-string))

(include "slib-compat")

(include "strsrch")

; these shouldn't be literals
(define *prec:comment-start* 200)
(define *prec:comment-weight* 220)

(include "prec")

;FIXME fixes what by duplicating `tok:read-through-comment' behavior?
(set! prec:commentfix (lambda (tk stp match . binds)
  ;;from tok:read-through-comment
  (set! match (if (char? match)
                  (string match)
                  (prec:de-symbolfy match)))
  (append
   (prec:make-nud tk prec:parse-nudcomment stp match (apply append binds))
   (prec:make-led tk *prec:comment-weight* prec:parse-ledcomment stp match (apply append binds)))))

(define (syntax-begin! #!optional (base '()))   (set! *syn-defs* base))
(define (syntax-end!)                           (set! *syn-defs* '()))
(define (syntax-current)                        *syn-defs*)
(define (syntax-ignore-whitespace)              *syn-ignore-whitespace*)

(include "prec-setup")

;;

(define (prec:infixr tk sop lbp . binds)
  (let* (
    (bp (and (not (null? binds)) (number? (car binds)) (car binds)))
    (binds (if bp (cdr binds) binds))
    (bp (or bp (max 0 (- lbp 1)))) )
    (apply prec:infix tk sop lbp bp binds) ) )

;;

(define (make-grammar src #!optional (base '()))
  (let* (
    (imd (*parse-grammer-source 'make-grammar src base))
    (grm (*eval-grammer-form 'make-grammar imd base)) )
    (syntax-begin! base)
    (apply prec:define-grammar grm)
    (syntax-current) ) )

; tok <kind> <args>...
;
; <kind>
;
; _f                              delim
;
; f                               nofix       : sop
;
; f_f                             commentfix  : stp match rule1 ...
;
; fx fy                           prefix      : sop bp rule1 ...
; xf yf                           postfix     : sop bp
; xfx xfy yfx yfy                 infix       : sop lbp bp rule1 ...
; xfx xfy yfx yfy                 infix       : sop lbp bp rule1 ...
;
; xfs                             nary        : sop bp
; fs                              prestfix    : sop bp rule1 ...
;
; fxf                             matchfix    :  sop sep match rule1 ...
; fyf                             inmatchfix  :  sop sep match lbp rule1 ...

(define (*parse-grammer-source loc src base)
  (begin) )

(define (*eval-grammer-form loc imd base)
  (begin) )

) ;slib-prec