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

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

;; Note on strings:
;;  the allocated length does not include an extra byte on the end for the null terminator!

(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.
  ;; BUG - string should probably be (-> obj type), not that it matters, I don't think
  ;;  anybody makes a subclass of 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)
      )
    )
  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
        )
      )
    )
  )

(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."
  (local-vars (b-ptr (pointer uint8)) (a-ptr (pointer uint8)))
  (set! a-ptr (-> str-a data))
  (set! b-ptr (-> str-b data))
  (if (or (zero? str-a) (zero? str-b))
      (return '#f)
      )
  ;; loop until we reach the end of one string
  (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 at the end.
  (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?"
  (local-vars (str-ptr (pointer uint8)))
  (set! 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-to-string arg1))
     )
    ((and (= (-> arg1 type) string) (= (-> arg0 type) symbol))
     (string= (the-as string arg1) (symbol-to-string arg0))
     )
    )
  )

(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."
  (local-vars (str-ptr (pointer uint8)) (i int))
  (set! str-ptr (-> str data))
  (set! i 0)
  (while (< i len)
    (set! (-> str-ptr 0) (-> charp 0))
    (set! str-ptr (&-> str-ptr 1))
    (set! charp (&-> charp 1))
    (set! i (+ i 1))
    )
  (set! (-> str-ptr 0) 0)
  str
  )

(defun string<-charp ((str string) (charp (pointer uint8)))
  "Copy all chars from a char* to a GOAL string.
   Does NO length checking."
  (local-vars (str-ptr (pointer uint8)))
  (set! 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) 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"
  (local-vars (a-ptr (pointer uint8))  (b-ptr (pointer uint8)))
  (set! a-ptr (-> a data))
  (set! b-ptr (-> b data))
  ;; seek to the end of a
  (while (nonzero? (-> a-ptr 0))
    (nop!)
    (nop!)
    (nop!)
    (set! a-ptr (&-> a-ptr 1))
    )
  ;; append b
  (while (nonzero? (-> b-ptr 0))
    (set! (-> a-ptr 0) (-> b-ptr 0))
    (set! a-ptr (&-> a-ptr 1))
    (set! b-ptr (&-> b-ptr 1))
    )
  ;; null terminate
  (set! (-> a-ptr 0) 0)
  a
  )

(defun catn-string<-charp ((a string) (b (pointer uint8)) (len int))
  "Append b to a, exactly len chars"
  (local-vars (a-ptr (pointer uint8)) (i int) )
  (set! a-ptr (-> a data))
  ;; seek to end of a
  (while (nonzero? (-> a-ptr 0))
    (nop!)
    (nop!)
    (nop!)
    (set! a-ptr (&-> a-ptr 1))
    )
  ;; append
  (set! i 0)
  (while (< i len)
    (set! (-> a-ptr 0) (-> b 0))
    (set! a-ptr (&-> a-ptr 1))
    (set! b (&-> b 1))
    (set! i (+ i 1))
    )
  (set! (-> a-ptr 0) 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
    )
  )

(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
  )


;; 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?"
  (local-vars (i int) (len int))

  ;; get the minimum length.
  ;; note - we don't do virtual calls here for some reason.
  (set! len (min ((method-of-type string length) a)
                 ((method-of-type string length) b)
                 )
        )

  ;; loop through chars, up until the minimum length.
  (set! i 0)
  (while (< i len)
   (cond
    ((< (-> a data i) (-> b data i)) (return '#t))
    ((< (-> b data i) (-> a data i)) (return '#f))
    )
   (set! i (+ i 1))
   )
  '#f
  )

(defun string>? ((a string) (b string))
  "In dictionary order, is a > b?"
  (local-vars (i int) (len int))
  (set! len (min ((method-of-type string length) a)
                 ((method-of-type string length) b))
        )
  (set! i 0)
  (while (< i len)
    (cond
      ((< (-> a data i) (-> b data i)) (return '#f))
      ((< (-> b data i) (-> a data i)) (return '#t))
      )
    (set! i (+ i 1))
    )
  '#f
  )

(defun string<=? ((a string) (b string))
  (local-vars (i int) (len int))
  (set! len (min ((method-of-type string length) a)
                 ((method-of-type string length) b))
   )
  (set! i 0)
  (while
   (< i len)
   (cond
    ((< (-> a data i) (-> b data i)) (return '#t))
    ((< (-> b data i) (-> a data i)) (return '#f))
    )
   (set! i (+ i 1))
   )
  '#t
  )

(defun string>=? ((a string) (b string))
  (local-vars (i int) (len int))
  (set! len (min ((method-of-type string length) a)
                 ((method-of-type string length) b))
        )
  (set! i 0)
  (while (< i len)
    (cond
      ((< (-> a data i) (-> b data i)) (return '#f))
      ((< (-> b data i) (-> a data i)) (return '#t))
      )
    (set! i (+ i 1))
    )
  '#t
  )

;; 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 of base-str, up to the last occurance of char in append-str"
  (local-vars
   (location-of-char (pointer uint8))
   (end-of-append (pointer uint8))
   )

  ;; point to one before the beginning of the append string (kind of a hack)
  (set! end-of-append (&-> (the-as (pointer uint8) append-str) 3))
  ;; try to find char in append-str
  (set! location-of-char (string-skip-to-char (-> append-str data) char))
  (when (= (-> location-of-char 0) char)
    ;; found it!
    (until
        (begin
         ;; update the location of the last find
         (set! end-of-append location-of-char)
         ;; try to find another
         (set! location-of-char (string-skip-to-char (&-> location-of-char 1) char))
         ;; did we succeed?
         (!= (-> location-of-char 0) char)
         )
      (none)
      )
    )
  ;; now location-of-char points to the last occurance.
  ;; or to 1 before the start of append-str if we never found it.
  (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."
  (local-vars
   (arg-start (pointer uint8))
   (v1-11 (pointer uint8))
   (a0-6 symbol)
   (a0-20 symbol)
   (a1-3 (pointer uint8))
   (a1-9 (pointer uint8))
   (arg-word-start (pointer uint8))
   (arg-end (pointer uint8))
   )
  ;; seek up the beginning of a word.
  (set! arg-word-start (string-skip-whitespace (-> arg data)))
  (cond
    ((= (-> arg-word-start 0) 34) ;; starts with quote
     ;; seek past quote to first char of name
     (set! arg-end (&-> arg-word-start 1))
     ;; now, find the end
     (set! arg-start arg-end)
     (while (and (nonzero? (-> arg-end 0))
                 ;; (nonzero? (+ (-> arg-end 0) -34))
                 (!= (-> arg-end 0) 34) ;; quote
                 )
       (set! arg-end (&-> arg-end 1))
       )

     ;; copy to output.
     (copyn-string<-charp a-str arg-start (- (the-as int arg-end) (the-as uint arg-start)))

     ;; if we got a close quote
     (when (= (-> arg-end 0) 34)
       ;; seek past it
       (set! arg-end (&-> arg-end 1))
       )
     (set! a1-3 (string-skip-whitespace arg-end))
     (string-suck-up! arg a1-3)
     (return '#t)
     )
    ((nonzero? (-> arg-word-start 0))

     (set! v1-11 arg-word-start)
     (while
         (and
          (nonzero? (-> arg-word-start 0))
          (nonzero? (+ (-> arg-word-start 0) -32))
          (nonzero? (+ (-> arg-word-start 0) -9))
          (nonzero? (+ (-> arg-word-start 0) -13))
          (nonzero? (+ (-> arg-word-start 0) -10))
          )
       (set! arg-word-start (&-> arg-word-start 1))
       )
     (copyn-string<-charp a-str v1-11 (- (the-as int arg-word-start) (the-as uint v1-11)))
     (set! 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*
     )
  )