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

;;-*-Lisp-*-
(in-package goal)
(bundles "KERNEL.CGO")
(require "kernel/gstring-h.gc")
(require "kernel/gcommon.gc")

;; 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.

;; DECOMP BEGINS

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

(defmethod length ((this string))
  "Return the number of bytes before the null terminator."
  (let ((cursor (-> this data)))
    (while (nonzero? (-> cursor 0))
      (nop!)
      (nop!)
      (nop!)
      (set! cursor (&-> cursor 1)))
    (&- cursor (the-as uint (-> this data)))))

(defmethod asize-of ((this string))
  "Return the string header, allocated byte capacity, and null terminator size."
  (+ (-> this allocated-length) 1 (-> string size)))

(defun copy-string<-string ((dst string) (src string))
  "Copy src and its null terminator into dst without checking capacity."
  (let ((dst-ptr (-> dst data)))
    (let ((src-ptr (-> src data)))
      (while (nonzero? (-> src-ptr 0))
        (set! (-> dst-ptr 0) (-> src-ptr 0))
        (set! dst-ptr (&-> dst-ptr 1))
        (set! src-ptr (&-> src-ptr 1))))
    (set! (-> dst-ptr 0) (the-as uint 0)))
  dst)

(defun copyn-string<-string ((dst string) (src string) (len int))
  "Copy len bytes from src when it contains at least len bytes, then terminate dst."
  (let ((dst-ptr (-> dst data))
        (src-ptr (-> src data)))
    (when (<= 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 half-open byte range [start, end) to dst, or return an empty string for invalid indices."
  (let ((strlen (length src)))
    (if (and (>= start 0) (<= start end) (<= 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))
  "Allocate a string with at least size bytes, copying other when supplied."
  (cond
    (other
     (let* ((desired-size (max (length other) size))
            (new-string (object-new allocation type-to-make (+ desired-size 1 (-> type-to-make size)))))
       (set! (-> new-string allocated-length) desired-size)
       (copy-string<-string new-string other)))
    (else
     (let ((new-string (object-new allocation type-to-make (+ size 1 (-> type-to-make size)))))
       (set! (-> new-string allocated-length) size)
       new-string))))

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

(defun string= ((str-a string) (str-b string))
  "Return true when two non-null GOAL strings contain the same bytes."
  (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)))
    (and (zero? (-> a-ptr 0)) (zero? (-> b-ptr 0)))))

(defun string-charp= ((str string) (charp (pointer uint8)))
  "Return true when a GOAL string and null-terminated byte string contain the same bytes."
  (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= ((left basic) (right basic))
  "Compare two strings or symbols by name."
  (cond
    ((= left right) #t)
    ((and (= (-> left type) string) (= (-> right type) string)) (string= (the-as string left) (the-as string right)))
    ((and (= (-> left type) string) (= (-> right type) symbol))
     (string= (the-as string left) (symbol->string (the-as symbol right))))
    ((and (= (-> right type) string) (= (-> left type) symbol))
     (string= (the-as string right) (symbol->string (the-as symbol left))))))

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

(defun copyn-string<-charp ((str string) (charp (pointer uint8)) (len int))
  "Copy exactly len bytes from a C string and append a null terminator."
  (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 a null-terminated byte string into a GOAL string without checking capacity."
  (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 ((charp (pointer uint8)) (str string))
  "Copy a GOAL string and its null terminator into a byte buffer."
  (let ((str-ptr (-> str data)))
    (while (nonzero? (-> str-ptr 0))
      (set! (-> charp 0) (-> str-ptr 0))
      (set! charp (&-> charp 1))
      (set! str-ptr (&-> str-ptr 1))))
  (set! (-> charp 0) (the-as uint 0))
  0)

(defun copy-charp<-charp ((dst (pointer uint8)) (src (pointer uint8)))
  "Copy a null-terminated byte string and return its destination terminator."
  (while (nonzero? (-> src 0))
    (set! (-> dst 0) (-> src 0))
    (set! dst (&-> dst 1))
    (set! src (&-> src 1)))
  (set! (-> dst 0) (the-as uint 0))
  dst)

(defun cat-string<-string ((a string) (b string))
  "Append b to a without checking capacity."
  (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 exactly len bytes from b to a and add a null terminator."
  (let ((a-ptr (-> a data)))
    (while (nonzero? (-> a-ptr 0))
      (nop!)
      (nop!)
      (nop!)
      (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 bytes from b through end-ptr inclusive, stopping earlier at b's null terminator. Return the new terminator."
  (let ((b-ptr (-> b data))
        (a-ptr (-> a data)))
    (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) (the-as uint 0))
    a-ptr))

(defun append-character-to-string ((str string) (char uint8))
  "Append one byte and a new null terminator without checking capacity."
  (let ((str-ptr (-> str data)))
    (while (nonzero? (-> str-ptr 0))
      (nop!)
      (nop!)
      (nop!)
      (set! str-ptr (&-> str-ptr 1)))
    (set! (-> str-ptr 0) (the-as uint char))
    (set! (-> str-ptr 1) (the-as uint 0)))
  0)

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

(defun string-upcase ((in string) (out string))
  "Convert ASCII lowercase letters from in to uppercase in out."
  (let* ((in-ptr (-> in data))
         (in-data (-> in-ptr 0))
         (in-idx 1)
         (out-idx 0))
    (while (nonzero? in-data)
      (if (and (>= in-data (the-as uint 97)) (>= (the-as uint 122) in-data)) (+! in-data -32))
      (set! (-> out data out-idx) in-data)
      (set! in-data (-> in-ptr in-idx))
      (+! in-idx 1)
      (+! out-idx 1))
    (set! (-> out data out-idx) (the-as uint 0)))
  out)

(defun string-downcase ((in string) (out string))
  "Convert ASCII uppercase letters from in to lowercase in out."
  (let* ((in-ptr (-> in data))
         (in-data (-> in-ptr 0))
         (in-idx 1)
         (out-idx 0))
    (while (nonzero? in-data)
      (if (and (>= in-data (the-as uint 65)) (>= (the-as uint 90) in-data)) (+! in-data 32))
      (set! (-> out data out-idx) in-data)
      (set! in-data (-> in-ptr in-idx))
      (+! in-idx 1)
      (+! out-idx 1))
    (set! (-> out data out-idx) (the-as uint 0)))
  out)

(defun charp-basename ((charp (pointer uint8)))
  "Return the bytes after the final slash or backslash, or the original pointer when neither occurs."
  (let ((ptr charp))
    (while (nonzero? (-> ptr 0))
      (set! ptr (&-> ptr 1)))
    (while (< (the-as int charp) (the-as int ptr))
      (set! ptr (&-> ptr -1))
      (if (or (= (-> ptr 0) 47) (= (-> ptr 0) 92)) (return (&-> ptr 1)))))
  charp)

(defun clear ((str string))
  "Make a string empty and return it."
  (set! (-> str data 0) (the-as uint 0))
  str)

;;;;;;;;;;;;;;;;;;;;;;;;;
;; 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))
  "Compare the shared prefix bytewise and return true when a first differing byte in a is smaller. A strict prefix is not considered smaller."
  (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))
  "Compare the shared prefix bytewise and return true when a first differing byte in a is larger. A strict prefix is not considered larger."
  (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))
  "Compare the shared prefix bytewise and return false only when a first differing byte in a is larger."
  (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))
  "Compare the shared prefix bytewise and return false only when a first differing byte in a is smaller."
  (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-as string #f)))

(defun string-skip-to-char ((cursor (pointer uint8)) (char uint))
  "Return the first occurrence of char, or the null terminator when it is absent."
  (while (and (nonzero? (-> cursor 0)) (!= (-> cursor 0) char))
    (set! cursor (&-> cursor 1)))
  cursor)

(defun string-cat-to-last-char ((base-str string) (append-str string) (char uint))
  "Append append-str through its final occurrence of char, or append nothing when char is absent."
  (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 ((cursor (pointer uint8)))
  "Return the first byte not containing space, tab, carriage return, or newline."
  (while (and (nonzero? (-> cursor 0)) (is-whitespace-char? (-> cursor 0)))
    (set! cursor (&-> cursor 1)))
  cursor)

(defun string-suck-up! ((str string) (location (pointer uint8)))
  "Remove every byte before location by moving the remaining suffix to the start of str."
  (when (!= location (-> str data))
    (let ((str-ptr (-> str data)))
      (while (nonzero? (-> location 0))
        (set! (-> str-ptr 0) (-> location 0))
        (set! str-ptr (&-> str-ptr 1))
        (set! location (&-> location 1)))
      (set! (-> str-ptr 0) (the-as uint 0)))
    0)
  #f)

(defun string-strip-leading-whitespace! ((str string))
  "Remove spaces, tabs, carriage returns, and newlines from the start of a string."
  (let ((content-start (string-skip-whitespace (-> str data)))) (string-suck-up! str content-start))
  #f)

(defun string-strip-trailing-whitespace! ((str string))
  "Remove spaces, tabs, carriage returns, and newlines from 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! ((str string))
  "Remove spaces, tabs, carriage returns, and newlines from both ends of a string."
  (string-strip-trailing-whitespace! str)
  (string-strip-leading-whitespace! str)
  #f)

(defun string-get-arg!! ((a-str string) (arg string))
  "Remove and copy the first whitespace-delimited argument. Quoted arguments may contain whitespace."
  (let ((arg-word-start (string-skip-whitespace (-> arg data))))
    (cond
      ((= (-> arg-word-start 0) 34)
       (let ((arg-end (&-> arg-word-start 1)))
         (let ((arg-start arg-end))
           (while (and (nonzero? (-> arg-end 0)) (!= (-> arg-end 0) 34))
             (set! arg-end (&-> arg-end 1)))
           (copyn-string<-charp a-str arg-start (&- arg-end (the-as uint arg-start))))
         (if (= (-> arg-end 0) 34) (set! arg-end (&-> arg-end 1)))
         (let ((next-arg (string-skip-whitespace arg-end))) (string-suck-up! arg next-arg)))
       (return #t))
      ((nonzero? (-> arg-word-start 0))
       (let ((arg-start arg-word-start))
         (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 arg-start (&- arg-word-start (the-as uint arg-start))))
       (let ((next-arg (string-skip-whitespace arg-word-start))) (string-suck-up! arg next-arg))
       (return #t))))
  #f)

(defun string->int ((str string))
  "Parse a decimal, #x hexadecimal, or #b binary integer. Parsing stops at the first invalid digit."
  (let ((str-ptr (-> str data))
        (result 0)
        (negate #f))
    (cond
      ((= (-> str-ptr 0) 35)
       (let ((next-char-1 (&-> str-ptr 1)))
         (cond
           ((or (= (-> next-char-1 0) 120) (= (-> next-char-1 0) 88))
            (let ((next-char-2 (&-> next-char-1 1)))
              (when (= (-> next-char-2 1) 45)
                (set! negate #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)))
                   (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)))
                   (set! result (the-as int (+ (-> next-char-2 0) -87 (* result 16)))))
                  (else (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))
            (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
       (when (= (-> str-ptr 1) 45)
         (set! negate #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
      (negate (- result))
      (else (empty) result))))

(defun string->float ((str string))
  "Convert a decimal string to a float. The original EE implementation reports that conversion is unsupported."
  (#unless PC_PORT
    (format 0 "string->float left as an excersize for the reader~%")
    0.0)
  (#when PC_PORT
    (let ((charp (-> str data))
          (result 0.0)
          (negative #f))
      (when (= (-> charp) #\-)
        (set! negative #t)
        (&+! charp 1))
      (while (and (>= (-> charp) #\0) (<= (-> charp) #\9))
        (*! result 10)
        (+! result (- (-> charp) #\0))
        (&+! charp 1))
      (when (= (-> charp) #\.)
        (&+! charp 1)
        (let ((frac 1.0))
          (while (and (>= (-> charp) #\0) (<= (-> charp) #\9))
            (*! frac 10)
            (+! result (/ (the float (- (-> charp) #\0)) frac))
            (&+! charp 1))))
      (cond
        (negative (- result))
        (else result)))))

(defun string-get-int32!! ((result (pointer int32)) (args string))
  "Consume the next argument, parse it as an integer, and store it in result."
  (cond
    ((string-get-arg!! *string-tmp-str* args) (set! (-> result 0) (string->int *string-tmp-str*)) #t)
    (else #f)))

(defun string-get-float!! ((result (pointer float)) (args string))
  "Consume the next argument, parse it as a float, and store it in result."
  (cond
    ((string-get-arg!! *string-tmp-str* args) (set! (-> result 0) (string->float *string-tmp-str*)) #t)
    (else #f)))

(defun string-get-flag!! ((result (pointer symbol)) (in string) (first-flag string) (second-flag string))
  "Consume the next argument when it matches either flag; store true for first-flag and false for second-flag."
  (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 strings.
(define *temp-string* (new 'global 'string 256 (the string #f)))

(define *temp-string2* (new 'global 'string 256 (the string #f)))

(define *pc-cpp-temp-string*
  "A convenient place to retrieve a string from C++"
  (new 'global 'string 256 (the-as 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*))