jak-project/goal_src/jak1/kernel/gstring.gc

;;-*-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
  )

(defun copyn-string<-string ((dst string) (src string) (len int))
  "Copy len bytes of data from one string to another, like strncpy"
  (let ((dst-ptr (-> dst data))
        (src-ptr (-> src data))
        )
    (if (<= len (length src))
      (dotimes (i len)
        (set! (-> dst-ptr) (-> src-ptr))
        (&+! dst-ptr 1)
        (&+! src-ptr 1)
        )
      )
    (set! (-> dst-ptr 0) 0)
    )
  dst
  )

(defun substring! ((dst string) (src string) (start int) (end int))
  "Copy the specified substring to dst. Returns an empty string if invalid indices are given."
  (let ((strlen (length src)))
    (if (and (< start strlen) (<= end strlen))
      (let ((start-ptr (-> src data))
            (dst-ptr (-> dst data))
            )
            (dotimes (i (- end start))
              (set! (-> dst-ptr) (-> start-ptr (+ start i)))
              (&+! dst-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)
       )
  )

(defmacro not-whitespace-char? (c)
  `(not (is-whitespace-char? ,c))
  )

(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"
  (when (nonzero? (length str))
    (let ((ptr (&+ (-> str data) (+ (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) (the-as uint 0))
      )
    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?"
  (let ((str-ptr (-> str data))
        (result 0)
        (negative #f)
        )
    (cond
      ((= (-> str-ptr 0) 35)
       ;; starts with #.
       (let ((next-char-1 (&-> str-ptr 1)))
         (cond
           ((or (= (-> next-char-1 0) 120) (= (-> next-char-1 0) 88))
            ;; starts with #x or #X
            (let ((next-char-2 (&-> next-char-1 1)))
              (when (= (-> next-char-2 1) 45)
                ;; negate!
                (set! negative #t)
                (set! next-char-2 (&-> next-char-2 1))
                )
              (while (or
                       (and (>= (-> next-char-2 0) (the-as uint 48)) (>= (the-as uint 57) (-> next-char-2 0)))
                       (and (>= (-> next-char-2 0) (the-as uint 65)) (>= (the-as uint 70) (-> next-char-2 0)))
                       (and (>= (-> next-char-2 0) (the-as uint 97)) (>= (the-as uint 102) (-> next-char-2 0)))
                       )
                (cond
                  ((and (>= (-> next-char-2 0) (the-as uint 65)) (>= (the-as uint 70) (-> next-char-2 0)))
                    ;; is in [A-F]
                   (set! result (the-as int (+ (-> next-char-2 0) -55 (* result 16))))
                   )
                  ((and (>= (-> next-char-2 0) (the-as uint 97)) (>= (the-as uint 102) (-> next-char-2 0)))
                    ;; is in [a-f]
                   (set! result (the-as int (+ (-> next-char-2 0) -87 (* result 16))))
                   )
                  (else
                    ;; is in [0-9]
                    (set! result (the-as int (+ (-> next-char-2 0) -48 (* result 16))))
                    )
                  )
                (set! next-char-2 (&-> next-char-2 1))
                )
              )
            )
           ((or (= (-> next-char-1 0) 98) (= (-> next-char-1 0) 66))
            ;; is #b (I guess we can't do negative binary?)
            (let ((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-as int (+ (-> a0-4 0) -48 (* result 2))))
                (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))
          )
        (while (and (>= (-> str-ptr 0) (the-as uint 48)) (>= (the-as uint 57) (-> str-ptr 0)))
          (set! result (the-as int (+ (-> str-ptr 0) -48 (* 10 result))))
          (set! str-ptr (&-> str-ptr 1))
          )
        )
      )
    (cond
      (negative
        (- result)
        )
      (else
        result
        )
      )
    )
  )

(defun string->float ((str 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

  ;; added...
  (let ((charp (-> str data))
        (result 0.0)
        (negative #f))

    (when (= (-> charp) #\-)
      (set! negative #t)
      (&+! charp 1)
      )

    (while (and (>= (-> charp) #\0) (<= (-> charp) #\9))
      ;; number

      (*! result 10) ;; bump oom (e.g. 123 -> 1230)
      (+! result (- (-> charp) #\0)) ;; add unit (e.g. 1230 -> 1234)
      (&+! charp 1)
      )

    (when (= (-> charp) #\.)
      ;; dot
      (&+! charp 1)
      ;; fractional part begin
      (let ((frac 1.0))
        (while (and (>= (-> charp) #\0) (<= (-> charp) #\9))
          ;; number

          (*! frac 10) ;; bump frac oom
          (+! result (/ (the float (- (-> charp) #\0)) frac)) ;; add frac (e.g. 1234 -> 1234.5)
          (&+! charp 1)
          )
        )
      )

    (cond
      (negative
        (- result)
        )
      (else
        result
        )
      )
    )
  )

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

;;;;;;;;;;;;;;;;;;;;;
;; Globals
;;;;;;;;;;;;;;;;;;;;;

;; The *stdcon* buffer holds text to be printed to the screen for debugging.
;; Under the hood, there are actually two buffers: *stdcon1* and *stdcon0*

;; The *stdcon0* buffer is the default and is cleared on each frame.
;; The *stdcon1* buffer is cleared only if the game is unpaused. This keeps text
;; on screen for game objects, even when the game is paused and their logic does not run.

;; The kernel takes care of setting *stdcon* to one of these two buffers as needed.

(define *debug-draw-pauseable* #f)

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