;;-*-Lisp-*-
(in-package goal)

;; name: gstring.gc
;; name in dgo: gstring
;; dgos: KERNEL


;; The GOAL string type is like a C string plus a length field.
;; The number of bytes stored is the length + 1 for the null terminator.
;; Note that string is a bit of a special type, and the compiler assumes there is no
;; child type of string ever created.



;;;;;;;;;;;;;;;;;;;;;;;;;
;; String methods
;;;;;;;;;;;;;;;;;;;;;;;;;

(defmethod length string ((obj string))
  "Get the length of a string. Like strlen"
  (let ((str-ptr (-> obj data)))
    (while (!= 0 (-> str-ptr 0))
      (set! str-ptr (the (pointer uint8) (&+ str-ptr 1)))
      )
    (- (the int str-ptr) (the int (-> obj data)))
    )
  )

(defmethod asize-of string ((obj string))
  "get the size in bytes of a string."
  (+ (-> obj allocated-length) 1 (-> string size))
  )

(defun copy-string<-string ((dst string) (src string))
  "Copy data from one string to another, like strcpy"
  (let ((dst-ptr (-> dst data))
        (src-ptr (-> src data))
        )
    (while (!= 0 (-> src-ptr))
      (set! (-> dst-ptr) (-> src-ptr))
      (&+! dst-ptr 1)
      (&+! src-ptr 1)
      )
    (set! (-> dst-ptr 0) 0)
    )
  dst
  )

(defmethod new string ((allocation symbol) (type-to-make type) (size int) (other string))
  "Create a new string of the given size. If other is not #f, copy data from it."
  (cond
    (other
      (let* ((desired-size (max (length other) size))
             (new-obj (object-new allocation type-to-make (+ desired-size 1 (-> type-to-make size))))
             )
        (set! (-> new-obj allocated-length) size)
        (copy-string<-string new-obj other)
        new-obj
        )
      )
    (else
      (let ((new-obj (object-new allocation type-to-make (+ 1 size (-> type-to-make size)))))
        (set! (-> new-obj allocated-length) size)
        new-obj
        )
      )
    )
  )

;;;;;;;;;;;;;;;;;;;;;;;;;
;; String comparison
;;;;;;;;;;;;;;;;;;;;;;;;;

(defun string= ((str-a string) (str-b string))
  "Does str-a hold the same data as str-b?.
   If either string is null, returns #f."
  (let ((a-ptr (-> str-a data))
        (b-ptr (-> str-b data))
        )
    (if (or (zero? str-a) (zero? str-b))
        (return #f)
        )
    (while (and (nonzero? (-> a-ptr 0)) (nonzero? (-> b-ptr 0)))
      (if (!= (-> a-ptr 0) (-> b-ptr 0))
          (return #f)
          )
      (set! a-ptr (&-> a-ptr 1))
      (set! b-ptr (&-> b-ptr 1))
      )
    ;; only equal if both end here.
    (and (zero? (-> a-ptr 0)) (zero? (-> b-ptr 0)))
    )
  )

(defun string-charp= ((str string) (charp (pointer uint8)))
  "Is the data in str equal to the C string charp?"
  (let ((str-ptr (-> str data)))
    (while (and (nonzero? (-> str-ptr 0)) (nonzero? (-> charp 0)))
      (if (!= (-> str-ptr 0) (-> charp 0))
          (return #f)
          )
      (set! str-ptr (&-> str-ptr 1))
      (set! charp (&-> charp 1))
      )
    (and (zero? (-> str-ptr 0)) (zero? (-> charp 0)))
    )
  )

(defun name= ((arg0 basic) (arg1 basic))
  "Do arg0 and arg1 have the same name?
   This can use either strings or symbols"
  (cond
    ((= arg0 arg1)
     ;; Either same symbols, or same string objects, fast check pass!
     #t)
    ((and (= (-> arg0 type) string) (= (-> arg1 type) string))
     (string= (the-as string arg0) (the-as string arg1))
     )
    ((and (= (-> arg0 type) string) (= (-> arg1 type) symbol))
     (string= (the-as string arg0) (symbol->string arg1))
     )
    ((and (= (-> arg1 type) string) (= (-> arg0 type) symbol))
     (string= (the-as string arg1) (symbol->string arg0))
     )
    ;; no need to check symbol - symbol, that would have passed the first check.
    )
  )

;;;;;;;;;;;;;;;;;;;;;;;;;
;; String copying
;;;;;;;;;;;;;;;;;;;;;;;;;

(defun copyn-string<-charp ((str string) (charp (pointer uint8)) (len int))
  "Copy data from a charp to a GOAL string. Copies len chars, plus a null."
  (let ((str-ptr (-> str data)))
    (dotimes (i len)
      (set! (-> str-ptr 0) (-> charp 0))
      (set! str-ptr (&-> str-ptr 1))
      (set! charp (&-> charp 1))
      )
    (set! (-> str-ptr 0) (the-as uint 0))
    )
  str
  )

(defun string<-charp ((str string) (charp (pointer uint8)))
  "Copy all chars from a char* to a GOAL string.
   Does NO length checking."
  (let ((str-ptr (-> str data)))
    (while (nonzero? (-> charp 0))
      (set! (-> str-ptr 0) (-> charp 0))
      (set! str-ptr (&-> str-ptr 1))
      (set! charp (&-> charp 1))
      )
    (set! (-> str-ptr 0) (the-as uint 0))
    )
  str
  )

(defun charp<-string ((dst (pointer uint8)) (src-string string))
  "Copy a GOAL string into a character array."
  (let ((src (-> src-string data)))
    (while (!= 0 (-> src))
      (set! (-> dst) (-> src))
      (&+! dst 1)
      (&+! src 1)
      )
    (set! (-> dst) 0)
    0
    )
  )

(defun copy-charp<-charp ((dst (pointer uint8)) (src (pointer uint8)))
  "C string copy."
  (while (nonzero? (-> src 0))
    (set! (-> dst 0) (-> src 0))
    (set! dst (&-> dst 1))
    (set! src (&-> src 1))
    )
  (set! (-> dst 0) 0)
  dst
  )

(defun cat-string<-string ((a string) (b string))
  "Append b to a. No length checks"
  (let ((a-ptr (-> a data)))
    (let ((b-ptr (-> b data)))
      (while (nonzero? (-> a-ptr 0))
        (nop!)
        (nop!)
        (nop!)
        (set! a-ptr (&-> a-ptr 1))
        )
      (while (nonzero? (-> b-ptr 0))
        (set! (-> a-ptr 0) (-> b-ptr 0))
        (set! a-ptr (&-> a-ptr 1))
        (set! b-ptr (&-> b-ptr 1))
        )
      )
    (set! (-> a-ptr 0) (the-as uint 0))
    )
  a
  )

(defun catn-string<-charp ((a string) (b (pointer uint8)) (len int))
  "Append b to a, exactly len chars"
  (let ((a-ptr (-> a data)))
    (while (nonzero? (-> a-ptr 0))
      (set! a-ptr (&-> a-ptr 1))
      )
    (dotimes (i len)
      (set! (-> a-ptr 0) (-> b 0))
      (set! a-ptr (&-> a-ptr 1))
      (set! b (&-> b 1))
      )
    (set! (-> a-ptr 0) (the-as uint 0))
    )
  a
  )

(defun cat-string<-string_to_charp ((a string) (b string) (end-ptr (pointer uint8)))
  "Append b to a, using chars of b up to (and including) the one pointed to by end-ptr,
   or, until the end of b, whichever comes first."

  (let ((b-ptr (-> b data))
        (a-ptr (-> a data))
        )
    ;; seek to end of a
    (while (nonzero? (-> a-ptr 0))
      (nop!)
      (nop!)
      (nop!)
      (set! a-ptr (&-> a-ptr 1))
      )
    (while (and (>= (the-as int end-ptr) (the-as int b-ptr))
                (nonzero? (-> b-ptr 0)))
      (set! (-> a-ptr 0) (-> b-ptr 0))
      (set! a-ptr (&-> a-ptr 1))
      (set! b-ptr (&-> b-ptr 1))
      )
    (set! (-> a-ptr 0) 0)
    a-ptr
    )
  )


(defun append-character-to-string ((str string) (char uint8))
  "Append char to the end of the given string."
  (let ((str-ptr (-> str data)))
    (while (nonzero? (-> str-ptr 0))
      (nop!)
      (nop!)
      (nop!)
      (set! str-ptr (&-> str-ptr 1))
      )
    (set! (-> str-ptr 0) char)
    (set! (-> str-ptr 1) 0)
    0
    )
  )

;;;;;;;;;;;;;;;;;;;;;;;;;
;; String utilities
;;;;;;;;;;;;;;;;;;;;;;;;;

(defun charp-basename ((charp (pointer uint8)))
  "Like basename in C"
  (let ((ptr charp))
    ;; seek to end
    (while (nonzero? (-> ptr 0))
      (set! ptr (&-> ptr 1))
      )
    ;; and back up...
    (while (< (the-as int charp) (the-as int ptr))
      (set! ptr (&-> ptr -1))
      ;; (if (or (zero? (+ (-> ptr 0) -47)) (zero? (+ (-> ptr 0) -92)))
      ;; check for equal to / or \
      (if (or (= (-> ptr 0) #\/) (= (-> ptr 0) #\\))
          ;; return the next char after that
          (return (&-> ptr 1))
          )
      )
    ;; didn't find any slashes, return the whole thing.
    charp
    )
  )

(defun clear ((a0-0 string))
  "Make string empty"
  (set! (-> a0-0 data 0) 0) a0-0
  )


;;;;;;;;;;;;;;;;;;;;;;;;;
;; String ordering
;;;;;;;;;;;;;;;;;;;;;;;;;

;; NOTE: these string comparisons are a little broken.
;; ex: (string<? "asd" "asdf") = #f
;;     (string<? "asdf" "asd") = #f
;; these comparisons do not properly order strings.

(defun string<? ((a string) (b string))
  "In dictionary order, is a < b?"
  (let ((len (min (length a) (length b))))
    (dotimes (i len)
      (cond
        ((< (-> a data i) (-> b data i))
         (return #t)
         )
        ((< (-> b data i) (-> a data i))
         (return #f)
         )
        )
      )
    )
  #f
  )

(defun string>? ((a string) (b string))
  "In dictionary order, is a > b?"
  (let ((len (min (length a) (length b))))
    (dotimes (i len)
      (cond
        ((< (-> a data i) (-> b data i))
         (return #f)
         )
        ((< (-> b data i) (-> a data i))
         (return #t)
         )
        )
      )
    )
  #f
  )

(defun string<=? ((a string) (b string))
  (let ((len (min (length a) (length b))))
    (dotimes (i len)
      (cond
        ((< (-> a data i) (-> b data i))
         (return #t)
         )
        ((< (-> b data i) (-> a data i))
         (return #f)
         )
        )
      )
    )
  #t
  )

(defun string>=? ((a string) (b string))
  (let ((len (min (length a) (length b))))
    (dotimes (i len)
      (cond
        ((< (-> a data i) (-> b data i))
         (return #f)
         )
        ((< (-> b data i) (-> a data i))
         (return #t)
         )
        )
      )
    )
  #t
  )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; String argument parsing
;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; temporary string for argument functions
(define *string-tmp-str* (new 'global 'string 128 (the string #f)))

(defun string-skip-to-char ((str (pointer uint8)) (char uint))
  "Return pointer to first instance of char in C string, or to the null terminator if none"
  (while (and (nonzero? (-> str 0)) (!= (-> str 0) char))
    (set! str (&-> str 1))
    )
  str
  )

(defun string-cat-to-last-char ((base-str string) (append-str string) (char uint))
  "Append append-str to the end of base-str, up to the last occurance of char in append-str"
  (let ((end-of-append (&-> (the-as (pointer uint8) append-str) 3)))
    (let ((location-of-char (string-skip-to-char (-> append-str data) char)))
      (when (= (-> location-of-char 0) char)
        (until (!= (-> location-of-char 0) char)
          (set! end-of-append location-of-char)
          (set! location-of-char (string-skip-to-char (&-> location-of-char 1) char))
          )
        )
      )
    (cat-string<-string_to_charp base-str append-str end-of-append)
    )
  )


(defmacro is-whitespace-char? (c)
  ;; 32 = space
  ;; 9 = \t
  ;; 13 = \r
  ;; 10 = \n
  `(or (= ,c 32)
       (= ,c 9)
       (= ,c 13)
       (= ,c 10)
       )
  )

(defun string-skip-whitespace ((arg0 (pointer uint8)))
  "Skip over spaces, tabs, r's and n's"
  (while
      (and (nonzero? (-> arg0 0))
           (is-whitespace-char? (-> arg0 0))
           )
    (set! arg0 (&-> arg0 1))
    )
  arg0
  )

(defun string-suck-up! ((str string) (location (pointer uint8)))
  "Remove character between the start of string and location.
   The char pointed to by location is now the first."
  ;; fast check to do nothing if location points to start already.
  (when (!= location (-> str data))
    (let ((str-ptr (-> str data)))
      ;; copy back
      (while (nonzero? (-> location 0))
        (set! (-> str-ptr 0) (-> location 0))
        (set! str-ptr (&-> str-ptr 1))
        (set! location (&-> location 1))
        )
      ;; null terminate
      (set! (-> str-ptr 0) 0)
      )
    '#f
    )
  )

(defun string-strip-leading-whitespace! ((str string))
  "Remove whitespace at the front of a string"
  (let ((start-loc (string-skip-whitespace (-> str data))))
    (string-suck-up! str start-loc)
    )
  #f
  )

(defun string-strip-trailing-whitespace! ((str string))
  "Remove whitespace at the end of a string"
  (local-vars (ptr (pointer uint8)))
  (when (nonzero? ((method-of-type string length) str))
    (set! ptr (&+ (-> str data)
                  (the-as uint (+ ((method-of-type string length) str) -1)))
          )
    (while (and (>= (the-as int ptr) (the-as int (-> str data)))
                (is-whitespace-char? (-> ptr 0))
                )
      (set! ptr (&-> ptr -1))
      )
    (set! (-> ptr 1) 0)
    )
  '#f
  )

(defun string-strip-whitespace! ((arg0 string))
  "Remove whitespace at the beginning and end of a string"
  (string-strip-trailing-whitespace! arg0)
  (string-strip-leading-whitespace! arg0)
  '#f
  )

(defun string-get-arg!! ((a-str string) (arg string))
  "Get the first argument from a whitespace separated list of arguments.
   The arguments can be in quotes or not.
   Removes argument from arg string, sucks up white space before the next one
   Outputs argument to a-str."

  ;; seek to first arg
  (let ((arg-word-start (string-skip-whitespace (-> arg data))))
    (cond
      ((= (-> arg-word-start 0) 34) ;; starts with quote
       ;; seek past quote
       (let ((arg-end (&-> arg-word-start 1)))
         ;; now find end
         (let ((arg-start arg-end))
           (while (and (nonzero? (-> arg-end 0)) (!= (-> arg-end 0) 34)) ;; close quote
             (set! arg-end (&-> arg-end 1))
             )
           ;; copy to output
           (copyn-string<-charp a-str arg-start (&- arg-end (the-as uint arg-start)))
           )

         ;; if we got a close quote, seek past it.
         (if (= (-> arg-end 0) 34)
             (set! arg-end (&-> arg-end 1))
             )

         ;; kill leading white space
         (let ((a1-3 (string-skip-whitespace arg-end)))
           (string-suck-up! arg a1-3)
           )
         )
       (return #t)
       )
      ((nonzero? (-> arg-word-start 0))
       (let ((v1-11 arg-word-start))
         ;; find end
         (while (and
                 (nonzero? (-> arg-word-start 0))
                 (!= (-> arg-word-start 0) 32)
                 (!= (-> arg-word-start 0) 9)
                 (!= (-> arg-word-start 0) 13)
                 (!= (-> arg-word-start 0) 10)
                 )
           (set! arg-word-start (&-> arg-word-start 1))
           )
         (copyn-string<-charp a-str v1-11 (&- arg-word-start (the-as uint v1-11)))
         )
       (let ((a1-9 (string-skip-whitespace arg-word-start)))
         (string-suck-up! arg a1-9)
         )
       (return #t)
       )
      )
    )
  #f
  )

(defun string->int ((str string))
  "String to int. Supports binary, hex, and decimal. Negative is implemented for decimal and hex
   But I think it's broken?"
  (local-vars
   (result int)
   (negative symbol)
   (str-ptr (pointer uint8))
   (next-char-1 (pointer uint8))
   (next-char-2 (pointer uint8))
   (a0-4 (pointer uint8))
   (a0-5 symbol)
   (a1-14 uint)
   (a1-16 symbol)
   (a1-20 uint)
   (a1-23 uint)
   (a1-33 symbol)
   (a1-44 symbol)
   (a1-47 (pointer uint8))
   )
  (set! str-ptr (-> str data))
  (set! result 0)
  (set! negative '#f)
  (cond
    ((= (-> str-ptr 0) 35) ;; #
     ;; starts with #.
     (set! next-char-1 (&-> str-ptr 1))
     (cond
       ((or (= (-> next-char-1 0) #\x) (= (-> next-char-1 0) #\X))
        ;; starts with #x or #X
        (set! next-char-2 (&-> next-char-1 1))
        (when (= (-> next-char-2 1) #\-)
          ;; negate!
          (set! negative '#t)
          (set! next-char-2 (&-> next-char-2 1))
          )
        (while
            (or
             ;; is in [0-9]
             (and
              (>= (-> next-char-2 0) #\0)
              (>= (the-as uint #\9) (-> next-char-2 0))
              )
             ;; is in [A-F]
             (and
              (>= (-> next-char-2 0) (the-as uint 65))
              (>= (the-as uint 70) (-> next-char-2 0))
              )
             ;; is in [a-f]
             (and
              (>= (-> next-char-2 0) (the-as uint 97))
              (>= (the-as uint 102) (-> next-char-2 0))
              )
             )
          (cond
            ;; is in [A-F]
            ((and
              (>= (-> next-char-2 0) (the-as uint 65))
              (>= (the-as uint 70) (-> next-char-2 0))
              )
             (set!
              result
              (the int (+ (+ (-> next-char-2 0) -55) (the-as uint (shl result 4))))
              )
             )
            (else
             (set!
              a1-16
              (and
               (>= (-> next-char-2 0) (the-as uint 97))
               (>= (the-as uint 102) (-> next-char-2 0))
               )
              )
             (cond
               (a1-16
                ;; in [a-f]
                (set! result
                 (the int (+ (+ (-> next-char-2 0) -87) (the-as uint (shl result 4))))
                 )
                )
               (else
                ;; numeric
                (set! result
                 (the int (+ (+ (-> next-char-2 0) -48) (the-as uint (shl result 4))))
                 )
                ) ;; end numeric
               ) ;; end numeric or [a-f]
             ) ;; end not [A-F]
            ) ;; end cond
          (set! next-char-2 (&-> next-char-2 1))
          ) ;; end while
        )
       ((or (zero? (+ (-> next-char-1 0) -98)) (zero? (+ (-> next-char-1 0) -66)))
        ;; is #b (I guess we can't do negative binary?)
        (set! a0-4 (&-> next-char-1 1))
        (while (and (>= (-> a0-4 0) (the-as uint 48)) (>= (the-as uint 49) (-> a0-4 0)))
          (set! result (the int (+ (+ (-> a0-4 0) -48) (the-as uint (shl result 1)))))
          (set! a0-4 (&-> a0-4 1))
          )
        )
       )
     )
    (else
     ;; decimal

     ;; check for negative
     (when (= (-> str-ptr 1) 45)
       (set! negative '#t)
       (set! str-ptr (&-> str-ptr 1))
       (set! a1-47 str-ptr)
       )

     (while (and
          (>= (-> str-ptr 0) (the-as uint 48))
          (>= (the-as uint 57) (-> str-ptr 0))
          )
       (set! result (the int (+ (+ (-> str-ptr 0) -48) (the-as uint (* 10 result)))))
       (set! str-ptr (&-> str-ptr 1))
       )
     )
    )
  (cond (negative (- result)) (else result))
  )

(defun string->float ((arg0 string))
  "Convert a string to a float, but it is not implemented."
  (format 0 "string->float left as an excersize for the reader~%")
  0.0
  )

(defun string-get-int32!! ((arg0 (pointer int32)) (arg1 string))
  "Get an int32 from a list of arguments"
  (cond
   ((string-get-arg!! *string-tmp-str* arg1)
    (set! (-> arg0 0) (string->int *string-tmp-str*))
    '#t
    )
   (else '#f)
   )
  )

(defun string-get-float!! ((arg0 (pointer float)) (arg1 string))
  (cond
   ((string-get-arg!! *string-tmp-str* arg1)
    (set! (-> arg0 0) (string->float *string-tmp-str*))
    '#t
    )
   (else '#f)
   )
  )

(defun string-get-flag!! ((result (pointer symbol)) (in string) (first-flag string) (second-flag string))
  (local-vars (v1-0 symbol))
  (cond
    ((string-get-arg!! *string-tmp-str* in)
     (cond
       ((or (string= *string-tmp-str* first-flag)
            (string= *string-tmp-str* second-flag)
            )
        (set! (-> result 0) (string= *string-tmp-str* first-flag))
        '#t
        )
       (else '#f)
       )
     )
    (else '#f)
    )
  )

;; what is this?
(define *debug-draw-pauseable* #f)

;; console buffers. not sure what the two are for.
(define *stdcon0* (new 'global 'string 16384 (the string #f)))
(define *stdcon1* (new 'global 'string 16384 (the string #f)))
(define *stdcon* *stdcon0*)

;; shared temporary string.
(define *temp-string* (new 'global 'string 256 (the string #f)))

(defmacro string-format (&rest args)
  "Formats into *temp-string* and returns it, for in-place string formating.
   DO NOT USE *temp-string* WITH THIS MACRO! It is read as input AFTER all of the args evaluate."

  `(begin
     (format (clear *temp-string*) ,@args)
     *temp-string*
     )
  )