stdlib.slisp

;;; stdlib.lisp - Lisp standard library, pre-pended to user programs.
;;
;; We're consistent with argument usage so:
;;
;;     n is an integer.
;;     x is anything (cons, list, int, character, string, lambda, whatever).
;;    xs is a list.
;;    fn is a callable function, which in practice means a lambda.
;;
;; Some functions might have different arguments, but if they are anything listed
;; above then their value will always be as expected.
;;

;;; Contents

;;  0. Core
;;  1. Compatibility
;;  2. Printing
;;  3. Filesystem Functions
;;  4. Macros
;;  5. Maths functions
;;  5.1 Base conversion
;;  5.2 Maths functions
;;  6. List Creation
;;  7. List Utility Functions
;;  8. System functions.
;;  9. alist functions.
;; 10. plist functions.
;; 11. Conversion functions.
;; 12. Utility functions
;;
;; I tried to order the functions alphabetically, where it made sense.


;;; 0. Core
;;
;; We define a bunch of primitives inside our compiler/template.tmpl file,
;; these become immediately callable, however if we rely on that then we
;; lose the argument-checking facility.
;;
;; So we've defined our assembly-implemented primitives with a "sys_"-prefix
;; and here we present them to callers.
;;

(defun < (a b)
  "Return true if A < B"
  (sys_< a b))

(defun <= (a b)
  "Return true if A <= B"
  (sys_<= a b))

(defun > (a b)
  "Return true if A > B"
  (sys_> a b))

(defun >= (a b)
  "Return true if A >= B"
  (sys_>= a b))

(defun = (a b)
  "Return true if A = B"
  (sys_= a b))

(defun % (a b)
  "Perform A modulus B"
  (sys_% a b))

(defun alloc (n)
  "Allocate N bytes of string memory, and fill it with ASCII.

This is only supposed to be used alongside the `syscall` function.

NOTE There is no corresponding free function, the garbage collector will
reap orphaned memory."
  (sys_alloc n))

(defun alen (str)
  "Return the allocated size of the given string."
  (sys_alen str))

(defun car (xs)
  "Return the first item from the list"
  (sys_car xs))

(defun cdr (xs)
  "Return the tail of the list."
  (sys_cdr xs))

(defun chr (x)
  "Convert the given integer to a character."
  (sys_chr x))

(defun cons (a b)
  "Join A and B into a list"
  (sys_cons a b))

(defun environment ()
  "Return a list of all known environmental variables, and their values."
  (sys_environment))

(defun exit (n)
  "Terminate execution, with the specified integer status-code."
  (sys_exit n))

(defun explode (str)
  "Convert a string to a list of characters.

NOTE: This stops at the first NULL byte (0x00)."
  (sys_explode str))

(defun implode (xs)
  "Convert a list of characters to a string."
  (sys_implode xs))

(defun int (x)
  "Convert the given thing to an integer, if possible."
  (sys_int x))

(defun newline ()
  "Print a newline."
  (sys_newline))

(defun not (x)
  "Return true when given NIL, otherwise return NIL"
  (sys_not x))

(defun isqrt (x)
  "Perform an integer square root of the given number."
  (sys_isqrt x))

(defun nth (xs n)
  "Return the Nth item from the given list."
  (sys_nth xs n))

(defun nth! (xs n x)
  "Change the value of the Nth item from the given list, in-place."
  (sys_nth! xs n x))

(defun ord (c)
  "Return the ASCII character code of the given character."
  (sys_ord c))

(defun package (str)
  "Return the contents of the specified embedded package, if available."
  (sys_package str))

(defun packages ()
  "Return the names of all available embedded packages."
  (sys_packages))

;; NOP: This is a special form in our compiler
;; However if we make this then we can pretend
;; we load packages.
(defun require (x))

;; Load all embedded packages, again this is a nop
;; for compiled code, but inception can use it.
(defun require-all ()
  "Load all packages which are embedded in our run-time."
  (map (lambda (p) (require p)) (packages)))

(defun split (str c)
  "Split a string on the given character.

Return a list of (BEFORE . AFTER)."
  (sys_split str c))

(defun sqrt (x)
  "Return the floating-point square root of the given number."
  (sys_sqrt x))

(defun stdlib ()
  "Return the contents of the stdlib.slisp standard-library."
  (sys_stdlib))

(defun strat (str n)
  "Return the integer value of the character at offset N for the given string.

This ignores embedded NULLs which would otherwise break substr and explode."
  (sys_strat str n))

(defun strat! (str n x)
  "Update the content of the given string, by changing the byte at offset N to be X."
  (sys_strat! str n x))

(defun strcat (a b)
  "Return the result of concatenating the two specified strings into one."
  (sys_strcat a b))

(defun strcmp (a b)
  "Compare the two specified strings, return zero if equal."
  (sys_strcmp a b))

(defun strdup (str)
  "Return a heap-allocated copy of the given string."
  (sys_strdup str))

(defun string (x)
  "Convert the given item into a string, if possible."
  (sys_string x))

(defun strlen (str)
  "Return the length, in bytes, of the given string."
  (sys_strlen str))

;; Route to a wrapper to allow passing a specific number of arguments to our syscall primitive.
(defun syscall (&args)
  "Make an arbitrary Linux kernel system-call.
The first argument is the number of the function to call, after that the arguments are call-specific."
  (let ((len (length args)))
    (cond
      ((= len 1) (syscall_linux_1 (nth args 0)))
      ((= len 2) (syscall_linux_2 (nth args 0) (nth args 1)))
      ((= len 3) (syscall_linux_3 (nth args 0) (nth args 1) (nth args 2)))
      ((= len 4) (syscall_linux_4 (nth args 0) (nth args 1) (nth args 2) (nth args 3)))
      ((= len 5) (syscall_linux_5 (nth args 0) (nth args 1) (nth args 2) (nth args 3) (nth args 4)))
      ((= len 6) (syscall_linux_6 (nth args 0) (nth args 1) (nth args 2) (nth args 3) (nth args 4) (nth args 5)))
      (t nil))))

(defun syscall_linux_1 (a)
  "Invoke a kernel system-call with one argument."
  (sys_syscall a nil nil nil nil nil))

(defun syscall_linux_2 (a b)
  "Invoke a kernel system-call with two arguments."
  (sys_syscall a b nil nil nil nil))

(defun syscall_linux_3 (a b c)
  "Invoke a kernel system-call with three arguments."
  (sys_syscall a b c nil nil nil))

(defun syscall_linux_4 (a b c d)
  "Invoke a kernel system-call with four arguments."
  (sys_syscall a b c d nil nil))

(defun syscall_linux_5 (a b c d e)
  "Invoke a kernel system-call with five arguments."
  (sys_syscall a b c d e nil))

(defun syscall_linux_6 (a b c d e f)
  "Invoke a kernel system-call with six arguments."
  (sys_syscall a b c d e f))


;;; 1. Compatibility

;; Functions here are added for compatibility with other lisp dialects,
;; to allow easy copying/pasting of code.

(defun ! (x)
  "Shorthand for \"not\"."
  (not x))

(defun != (a b)
  "Return true if A != B"
  (not (= a b)))

(defun list? (x)
  "Return true if the given item is a list"
  (cons? x))

(defun string< (a b)
  "Return true if A < B."
  (< (strcmp a b) 0))

(defun string> (a b)
  "Return true if A > B."
  (> (strcmp a b) 0))

(defun string= (a b)
  "Return true if A = B."
  (= (strcmp a b) 0))

;; 4
(defun caar (x) (car (car x)))
(defun cadr (x) (car (cdr x)))
(defun cdar (x) (cdr (car x)))
(defun cddr (x) (cdr (cdr x)))

;; 8
(defun caaar (x) (car (car (car x))))
(defun caadr (x) (car (car (cdr x))))
(defun cadar (x) (car (cdr (car x))))
(defun caddr (x) (car (cdr (cdr x))))
(defun cdaar (x) (cdr (car (car x))))
(defun cdadr (x) (cdr (car (cdr x))))
(defun cddar (x) (cdr (cdr (car x))))
(defun cdddr (x) (cdr (cdr (cdr x))))

;; 16
(defun caaaar (x) (car (car (car (car x)))))
(defun caaadr (x) (car (car (car (cdr x)))))
(defun caadar (x) (car (car (cdr (car x)))))
(defun caaddr (x) (car (car (cdr (cdr x)))))
(defun cadaar (x) (car (cdr (car (car x)))))
(defun cadadr (x) (car (cdr (car (cdr x)))))
(defun caddar (x) (car (cdr (cdr (car x)))))
(defun cadddr (x) (car (cdr (cdr (cdr x)))))
(defun cdaaar (x) (cdr (car (car (car x)))))
(defun cdaadr (x) (cdr (car (car (cdr x)))))
(defun cdadar (x) (cdr (car (cdr (car x)))))
(defun cdaddr (x) (cdr (car (cdr (cdr x)))))
(defun cddaar (x) (cdr (cdr (car (car x)))))
(defun cddadr (x) (cdr (cdr (car (cdr x)))))
(defun cdddar (x) (cdr (cdr (cdr (car x)))))
(defun cddddr (x) (cdr (cdr (cdr (cdr x)))))

(defun eq (a b)
  "Compatiliby wrapper, the same as \"=\"."
  (= a b))

(defun eq? (a b)
  "Compatiliby wrapper, the same as \"=\"."
  (= a b))

(defun equal (a b)
  "Compatiliby wrapper, the same as \"=\"."
  (= a b))

(defun null? (x)
  "Is the given item nil?"
  (nil? x))

;; Ensure we have our syscall IDs defined
(require syscall)


;;; 2. Printing
;;
;; Note that our `print' function accepts a variable number of arguments
;; and will print each one in turn.

(defun print (&xs)
  "Print everything we're given.

This function accepts variadic arguments, and maps against a local lambda to
do the right thing for each entry in the given list."
  (map (lambda (x)
         (cond
           ((char? x)   (putc x))
           ((float? x)  (printfloat x))
           ((int? x)    (printint x))
           ((lambda? x) (printstr "<lambda>"))
           ((nil? x)    (printstr "<nil>"))
           ((str? x)    (printstr x))
           ((cons? x)   (do
                         (putc #\()
                         (print_cons x)  ; List items, separated by spaces
                          (putc #\))))
           (t           (printstr "unknown type")))) xs))

(defun println (&xs)
  "Print everything as `print' would.  Then print a newline."
  (map (lambda (x) (print x)) xs)
  (newline))

(defun print_cons (xs)
  "Print the contents of the list X, recursively."
  (print (car xs))
  (if (nil? (cdr xs))
      nil
      (if (cons? (cdr xs))
          (do
           (print " ")
           (print_cons (cdr xs)))
          (do
           (printstr " . ")
           (print (cdr xs))))))




;;; 3. Filesystem Functions
;;
;; These are functions which work with files, directories, and
;; their names/paths.
;;

(defun dir? (path)
  "Is the given path a directory?"
  (let ((res (stat path)))
    (if res
        (if (= 1 (car res))
            t))))

(defconst O_RDONLY       0)
(defconst O_DIRECTORY    65536)

(defun entries (path)
  "Return a list of directory entries beneath PATH, or nil on failure.

The implementation here is either horrid, or awesome.  You decide."

  (let ((fd 0)
        (size 8192)          ; size of the pool we read entries into.
        (buf (alloc size))   ; Allocate that pool for the results.
        (result nil)
        (n 0)
        (pos 0))

    (set! fd (syscall SYS_open path (+ O_RDONLY O_DIRECTORY) 0))
    (if (< fd 0)
        nil

        (do
          ;; Read a batch of directory entries.
          (set! n (syscall SYS_getdents64 fd buf size))

          (while (> n 0)

            (set! pos 0)

            ;; Walk the linux_dirent64 records.
            (while (< pos n)

              ;; offset 16: uint16 d_reclen
              ;; offset 18: uint8  d_type
              ;; offset 19: char[] d_name

              (let ((reclen (u16 buf (+ pos 16)))
                    (name-pos (+ pos 19))
                    (name-len 0))

                ;; Find the NUL terminator in d_name.
                (while (and
                         (< name-len (- reclen 19))
                         (not (= (u8 buf (+ name-pos name-len)) 0)))
                  (set! name-len (+ name-len 1)))

                ;; Allocate name + terminating NUL to copy the entry's filename into.
                (let ((name (alloc (+ name-len 1)))
                      (i 0))

                  ;; Copy the name byte-by-byte.
                  (while (< i name-len)
                    (strat! name i
                                (u8 buf (+ name-pos i)))
                    (set! i (+ i 1)))

                  ;; Add the terminating NUL.
                  (strat! name name-len 0)

                  ;; Add name to the result list.
                  (set! result (cons name result)))

                (set! pos (+ pos reclen))))
            (set! n (syscall SYS_getdents64 fd buf size)))

          (syscall SYS_close fd)

          (if (< n 0) nil result)))))

(defun exists? (path)
  "Does the named path exist?"
  (cons? (stat path)))

(defun fclose (handle)
  "Close the given handle.

As a special case closing a NIL file-handle is valid"
  (cond
    ((nil? handle) nil)
    ((int? handle)
      (let ((res 0))
        (set! res (syscall SYS_close handle))
        (if (>= res 0)
          res
         nil)))
    (t   (do (println "Calling fclose with an invalid handle-type") (exit 1)))))

(defun fopen (str mode)
  "Open a file with the given mode.

Mode is \"r\" for read, \"w\" for write, and \"a\" for append."
  (let ((flags 0)
        (handle 0))
    (cond
      ((= 0 (strcmp mode "a")) (set! flags 1089)) ; O_WRONLY|O_CREAT|O_APPEND
      ((= 0 (strcmp mode "r")) (set! flags    0)) ; O_RDONLY
      ((= 0 (strcmp mode "w")) (set! flags  577)) ; O_WRONLY|O_CREAT|O_TRUNC
      (t (do (println "unknown mode for fopen:" mode ) (exit 1))))
    (set! handle (syscall SYS_open str flags (octal "0o644")))
    (if (>= handle 0)
      handle
     nil)))

(defconst SEEK_END   2)
(defconst SEEK_START 0)

(defun fread (handle)
  "Read all available data from the given file-handle.

It is assumed the filehandle came from fopen, but nil is also accepted."
  (if (nil? handle)
    nil
    (let ((size 0))
      (set! size (syscall SYS_lseek handle 0 SEEK_END))
      (if (<= size 0)
         nil
         (do
           (if (< (syscall SYS_lseek handle 0 SEEK_START) 0)
             nil
             (let ((mem (alloc size))
                   (res (syscall SYS_read handle mem size)))
               (if (< res 0)
                   nil
                   mem))))))))

(defun fwrite (handle data len)
  "Write the given data, of length LEN, to the specified file-handle.

It is assumed the filehandle came from fopen, but nil is also accepted."
  (if (nil? handle)
    nil
    (let ((res (syscall SYS_write handle data len)))
      (if (>= res 0)
        res
       nil))))

(defun file? (path)
  "Is the given path a file?"
  (let ((res (stat path)))
    (if res
        (if (= 0 (car res))
            t))))

(defun mkdir (path)
  "Make the given directory.

Note that this does not create parents, use (mkdirs) for that."
  (if (< (syscall SYS_mkdir path (octal "0o755")) 0)
      nil
    1))

(defun mkdirs (path)
  "Make the given directory, creating parent directories as necessary"
  (mkdirs-helper (split-all path #\/) nil))

(defun mkdirs-helper (parts current)
  (if (nil? parts)
      t
      (let ((next (if (nil? current)
                      (car parts)
                      (strcat (strcat current "/")
                              (car parts)))))
        ;; make the next part if this part already exist.
        (if (not (dir? next))
            (mkdir next))
        (mkdirs-helper (cdr parts) next))))

(defun which (binary)
  "Return the complete path to the file, on the system $PATH, if possible."
  (let ((path (split-all (getenv "PATH") #\:))
        (res (filter path (lambda (dir) (exists? (join (list dir "/" binary)))))))
    (if res
        (join (list (car res) "/" binary)))))


(defun rmdir (path)
  (if (< (syscall SYS_rmdir path) 0)
      nil
    1))

;; undocumented
(defun u8 (buf pos)
  "Read and return a 8-bit value from the specified offset in the given buffer."
  (strat buf pos))

;; undocumented
(defun u16 (buf pos)
  "Read and return a 16-bit value from the specified offset in the given buffer."
  (+ (u8 buf pos) (* (u8 buf (+ pos 1)) 256)))

;; undocumented
(defun u32 (buf pos)
  "Read and return a 32-bit value from the specified offset in the given buffer."
  (+ (u16 buf pos) (* (u16 buf (+ pos 2)) 65536)))

;; undocumented
(defun u64 (buf pos)
  "Read and return a 64-bit value from the specified offset in the given buffer."
  (+ (u32 buf pos) (* (u32 buf (+ pos 4)) 4294967296)))

;; undocumented
(defun u64! (buf pos val)
  (sys_u64! buf pos val))

(defun stat (path)
  "Return details of the given filesystem entry.

This returns a list of the form (TYPE SIZE MODE)."

 ;; buf holds the return value from the stat call.
 ;; 64-bit Linux (x86_64): The struct stat structure is typically 144 bytes so this string is 145 bytes long.
 (let ((buf "                                                                                                                                                 "))
    (let ((result (syscall SYS_stat path buf)))
      (if (< result 0)
         nil                                     ; stat failed
          (do
            (let ((type (& (u32 buf 24) 61440))  ; type is file type
                  (mode (& (u32 buf 24)   511))  ; mode holds permission bits
                  (size (u64 buf 48)))           ; file size
              (cond
                ((= type 32768) (set! type 0))   ; FILE    -> 0
                ((= type 16384) (set! type 1))   ; DIR     -> 1
                ((= type 40960) (set! type 2))   ; LINK    -> 2
                ((= type  8192) (set! type 3))   ; CHR     -> 3
                ((= type 24576) (set! type 4))   ; BLOCK   -> 4
                ((= type  4096) (set! type 5))   ; FIFO    -> 5
                ((= type 49152) (set! type 6))   ; SOCKET  -> 6
                (t (set! type -1))               ; UNKNOWN -> -1
                )
              (list type size mode)))))))        ; return the list

(defun unlink (path)
  "Delete the given file from the filesystem.

Use (rmdir) to remove directories instead of files."
  (if (< (syscall SYS_unlink path) 0)
      nil
    1))


;;; 4. Macros
;;
;; Some trivial macros, implementing useful things.

(defmacro and (&xs)
  "Return the value of the last argument, so long as every argument up to
that point is non-nil.

Stops, and returns nil, as soon as an argument is nil, without evaluating
any remaining remaining arguments."
  (if (nil? xs)
      t
      (if (nil? (cdr xs))
          (car xs)
          `(if ,(car xs) (and ,@(cdr xs)) nil))))

(defmacro benchmark (&body)
  "Return the time taken to run the given body."
  `(let ((n (now)))
     ,@body
     (- (now) n)))

(defmacro cond (&clauses)
  "Evaluate each clause's test, in turn, stopping at the first one that
is non-nil and returning the value of that clause's last body-expression
(or the test's own value, if the clause has no body).

Returns nil on no match"
  (if (nil? clauses)
      nil
      `(if ,(car (car clauses))
           (do ,@(cdr (car clauses)))
           (cond ,@(cdr clauses)))))

(defmacro dolist (lst &body)
  "Anaphoric list iteration: for each element of LST, bind it to 'it'
and run BODY for side-effects.  Returns nil."
  `(let ((dolist-rest ,lst))
     (while dolist-rest
       (let ((it (car dolist-rest)))
         ,@body)
       (set! dolist-rest (cdr dolist-rest)))))

(defmacro or (&xs)
  "Return the value of the first non-nil argument, it does not evaluate remaining arguments."
  (if (nil? xs)
      nil
      (if (nil? (cdr xs))
          (car xs)
          `(let ((or-value ,(car xs)))
             (if or-value or-value (or ,@(cdr xs)))))))

(defmacro time (&body)
  "Return the last expression executed, but report on the elapsed time."
  `(let ((start (now)))
     (let ((result (do ,@body)))
       (println "Elapsed: " (- (now) start) "ms")
       result)))

(defmacro when (c &body)
  "Run an unlimited number of expressions when the given condition is true."
  `(if ,c (do ,@body)))

(defmacro unless (c &body)
  "Run an unlimited number of expressions when the given condition is false."
  `(if ,c nil (do ,@body)))





;;; 5. Maths functions
;;
;; These are mostly about testing for specific values, or
;; processing items of lists.



;;; 5.1 base conversions


(defun digit-value (ch)
  "return the value of a given number, used for parsing binary/hex/octal strings"
  (cond
    ((= ch "0") 0)
    ((= ch "1") 1)
    ((= ch "2") 2)
    ((= ch "3") 3)
    ((= ch "4") 4)
    ((= ch "5") 5)
    ((= ch "6") 6)
    ((= ch "7") 7)
    ((= ch "8") 8)
    ((= ch "9") 9)

    ((= ch "a") 10)
    ((= ch "A") 10)
    ((= ch "b") 11)
    ((= ch "B") 11)
    ((= ch "c") 12)
    ((= ch "C") 12)
    ((= ch "d") 13)
    ((= ch "D") 13)
    ((= ch "e") 14)
    ((= ch "E") 14)
    ((= ch "f") 15)
    ((= ch "F") 15)

    (t -1)))

(defun integer-base? (text prefix base)
  "Is the given text a valid number in the specified base?"
  (let ((len (strlen text))
        (pos 2)
        (digit 0)
        (ok t))

    (if (< len 3)
        nil

        (if (or (!= (substr text 0 1) "0")
                (and (!= (substr text 1 1) prefix)
                     (!= (substr text 1 1) (upper prefix))))
            nil

            (do
              (while (and ok (< pos len))

                (set! digit (digit-value (substr text pos 1)))

                (if (or (< digit 0)
                        (>= digit base))
                    (set! ok nil))
                (set! pos (+ pos 1)))
              ok)))))

(defun parse-integer (text prefix base)
  (let ((value 0)
        (pos 2)
        (len (strlen text))
        (digit 0))

    ;; Assume the caller has already verified the prefix.
    (while (< pos len)
      (set! digit (digit-value (substr text pos 1)))

      (if (or (< digit 0) (>= digit base))
          (do
            (println "Invalid digit")
            (exit 1)))

      (set! value (+ (* value base) digit))
      (set! pos (+ pos 1)))
    value))


(defun binary (text)
  "Parse the given text as a binary number, complete with an 0b prefix.

See-also dec2binary."
  (parse-integer text "b" 2))

(defun binary? (text)
  (integer-base? text "b" 2))

(defun hex (text)
  "Parse the given text as a hex number, complete with an 0x prefix.

See-also dec2hex."
  (parse-integer text "x" 16))

(defun hex? (text)
  (integer-base? text "x" 16))

(defun octal (text)
  "Parse the given text as a binary number, complete with an 0o prefix.

See-also dec2octal"
  (parse-integer text "o" 8))

(defun octal? (text)
  (integer-base? text "o" 8))


;;; 5.1.1  base conversions from decimal

(defun base-digit (value)
  "Return the character representation of a digit value 0-15."
  (cond
    ((= value 0)  "0")
    ((= value 1)  "1")
    ((= value 2)  "2")
    ((= value 3)  "3")
    ((= value 4)  "4")
    ((= value 5)  "5")
    ((= value 6)  "6")
    ((= value 7)  "7")
    ((= value 8)  "8")
    ((= value 9)  "9")
    ((= value 10) "A")
    ((= value 11) "B")
    ((= value 12) "C")
    ((= value 13) "D")
    ((= value 14) "E")
    ((= value 15) "F")
    (t nil)))

(defun decimal-base (value prefix base)
  "Convert a decimal integer to a number in the specified base."
  (let ((result "")
        (remainder 0)
        (digit "")
        (negative nil))

    ;; Remember if our value was negative
    (if (< value 0)
        (do
          (set! negative t)
          (set! value (- 0 value))))

    ;; Zero is a special case because the loop below would not run.
    (if (= value 0)
        (set! result "0")

        (while (> value 0)
          (set! remainder (% value base))
          (set! digit (base-digit remainder))
          (set! result (strcat digit result))
          (set! value (/ value base))))

    ;; Restore sign if we need to.
    (if negative (set! result (strcat "-" result)))

    ;; Minimum width is two digits; mostly for hex digits.
    (if (= (strlen result) 1)
        (set! result (strcat "0" result)))

    (strcat prefix result)))

(defun dec2binary (value)
  "Convert a decimal integer to binary, with a 0b prefix.

See also binary, and binary?"
  (decimal-base value "0b" 2))

(defun dec2hex (value)
  "Convert a decimal integer to hexadecimal, with a 0x prefix.

See also hex, and hex?"
  (decimal-base value "0x" 16))

(defun dec2octal (value)
  "Convert a decimal integer to octal, with a 0o prefix.

See also octal, and octal?"
  (decimal-base value "0o" 8))



;;; 5.2 maths functions


;; Define the usual maths
(defun + (a b)
  "Addition operation."
  (sys_plus a b))

(defun - (a &b)
  "Subtraction operation."
  (if (car b)
      (sys_minus a (car b))
      (sys_minus 0 a)))

(defun * (a b)
  "Multiplication operation."
  (sys_multiply a b))

(defun / (a &b)
  "Division operation."
  (if (car b)
      (sys_divide a (car b))
      (sys_divide 1 (+ a 0.0))))

(defun & (a b)
  "Binary AND between two integers."
  (sys_and a b))

(defun | (a b)
  "Binary OR between two integers."
  (sys_or a b))

(defun ^ (a b)
  "Binary XOR between two integers."
  (sys_xor a b))

(defun abs (n)
  "Return the absolute value of N, as a positive number"
  (if (< n 0) (- 0 n) n))

(defun even? (n)
  "Return 1 if the number is even, nil otherwise."
  (= (% n 2 ) 0))

(defun max (xs)
  "Return the maximum integer from the list of numbers supplied."
  (if (nil? xs)
      xs
      (reduce xs
              (lambda (a b)
                (if (< a b) b a))
              (car xs))))

(defun min (xs)
  "Return the smallest integer from the list of numbers supplied."
  (if (nil? xs)
      xs
      (reduce xs
              (lambda (a b)
                (if (< a b) a b))
              (car xs))))

(defun neg? (n)
  "Return 1 if the number is negative, nil otherwise."
  (< n 0))

(defun odd? (n)
  "Return 1 if the number is odd, nil otherwise."
  (= (% n 2 ) 1))

(defun one? (n)
  "Return true if the number is one, NIL otherwise."
  (= n 1))

(defun pos? (n)
  "Return 1 if the number is positive, NIL otherwise."
  (> n 0))

(defun pow (x y)
  "Return X to the power of Y."
  (if (= 0 y)
      1
      (* x (pow x (- y 1)))))

;; Sum all the numbers in the given list
(defun sum (xs)
  "Return the sum of all the numbers in the list"
  (if xs
      (+ (car xs)
         (sum (cdr xs)))
      0))

(defun zero? (n)
  "Return true if the number is zero, NIL otherwise."
  (= n 0))



;;; 6. List Creation
;;
;; These are functions which are designed to create lists,
;; with ascending values for example.

(defmacro list (&xs)
  "Build a list containing the value of each argument, in order.
(list a b c) is the same as (cons a (cons b (cons c nil)))."
  (if (nil? xs)
      nil
      `(cons ,(car xs) (list ,@(cdr xs)))))

(defun nat (n)
  "Create a list of numbers ranging from 1-N, inclusive."
  (range 1 n 1))

(defun range (start end step)
  "Create a list of numbers between the start and end bounds, inclusive.
Incrementing by the given step each time."
  (if (<= start end)
      (cons start (range (+ start step) end step))
      nil))

(defun repeated (n x)
  "Return a list of length n whose elements are all x."
  (if (pos? n)
      (cons x (repeated (- n 1) x))))

(defun seq (n)
  "Create a list of number ranging from 0-N, inclusive."
  (range 0 n 1))



;;; 7. List Utility Functions
;;
;; These functions are mostly the implementations of standard
;; functions a user would expect, such as map/filter/find/member
;;

(defun append (xs item)
  "Append the given value to the specified list.  If the list is empty just return the specified item."
  (if (nil? xs)
      item
      (cons (car xs) (append (cdr xs) item))))

(defun drop (n xs)
  "Drop the first N items from the given list, and return the rest."
  (cond
    ((< n 1) xs)
    ((nil? xs) xs)
    (t (drop (- n 1) (cdr xs)))))

(defun every (xs fn)
  "Does every list item return non-nil when the given function is called?"
  (let ((res (filter xs fn)))
    (= (length res) (length xs))))

(defun filter (xs fn)
  "Return a list consisting of all members of the given list for which the given predicate returns non-nil."
  (if (nil? xs)
      nil
      (if (fn (car xs))
          (cons (car xs) (filter (cdr xs) fn))
          (filter (cdr xs) fn))))

(defun find (xs item)
  "Return the offsets of any occurrence of the item in the given list, nil on failure."
  (find-helper xs item 0))

(defun find-helper (xs item index)
  (if xs
      (if (= (car xs) item)
          (cons index
                (find-helper (cdr xs) item (+ index 1)))
          (find-helper (cdr xs) item (+ index 1)))
      nil))

(defun flatten (xs)
  "Converts a list of nested lists to a single list, flattening it."
  (if (nil? xs)
      nil
      (if (! (cons? (car xs)))
          (cons (car xs) (flatten (cdr xs)))
          (append (flatten (car xs)) (flatten (cdr xs))))))

(defun intersect (lst1 lst2)
  "Return a list of the common entries from the two lists, with no duplicates."
  (intersect-helper lst1 lst2 nil))

(defun intersect-helper (lst1 lst2 seen)
  (cond
    ((null? lst1) nil)
    ((member? seen (car lst1))
     (intersect-helper (cdr lst1) lst2 seen))
    ((member? lst2 (car lst1))
     (cons (car lst1)
           (intersect-helper (cdr lst1)
                             lst2
                             (cons (car lst1) seen))))
    (t
     (intersect-helper (cdr lst1) lst2 seen))))

(defun join (xs)
  "Join an arbitrary list of strings together into a single string."
  (if xs
      (join-helper (cdr xs) (car xs))
      ""))

(defun join-helper (xs acc)
  (if xs
      (join-helper
       (cdr xs)
       (strcat acc (car xs)))
      acc))

(defun join-by (xs sep)
  "Join a list of string-items by the given separator."
  (if xs
      (join-rest (cdr xs) (car xs) sep)
      ""))

(defun join-rest (xs acc sep)
  (if xs
      (join-rest
       (cdr xs)
       (strcat (strcat acc sep)
               (car xs))
       sep)
      acc))

(defun length (xs)
  "Return the length of the given list or string."
  (if (str? xs)
      (strlen xs)
      (if xs
          (+ 1 (length (cdr xs)))
          0)))

(defun map (fn xs)
  "Create a new list by calling the given function for every list element."
  (if (nil? xs)
      nil
      (cons (fn (car xs)) (map fn (cdr xs)))))

(defun member? (xs item)
  "Return true if the specified item is found within the given list."
  (cond
    ( (nil? xs) nil)
    ( (= item (car xs)) 1)
    ( t (member? (cdr xs) item))))

(defun reduce (xs fn acc)
  "This is our reduce function, which uses a list, a function, and the accumulator."
  (if (nil? xs)
      acc
      (reduce (cdr xs) fn (fn acc (car xs)))))

(defun repeat (n fn)
  "Execute the function N times."
  (while (> n 0)
    (fn n)
    (set! n (- n 1))))

(defun reverse (xs)
  "Reverse the contents of the specified list."
  (reverse-inner xs nil))

(defun reverse-inner (xs acc)
  "Helper to use an accumulator to reverse a list.  Used by 'reverse'"
  (if (nil? xs)
      acc
      (reverse-inner (cdr xs) (cons (car xs) acc))))

(defun some (xs fn)
  "Return the first non-nil result of calling the given function on the list."
  (if (nil? xs)
      nil
      (let ((res (fn (car xs))))
        (if res
            res
            (some (cdr xs) fn)))))

(defun split-all (str char)
  "Return a list of splitting the string by the given character.

  Empty parts are ignored."
  (if (or (nil? str) (= str ""))
      nil
      (filter (split-all-helper str char) (lambda (x) (> (length x) 0)))))

(defun split-all-helper (str char)
  "Recursive helper for splitting a list by character."
  (let ((parts (split str char)))
    (if (nil? parts)
        (list str)
        (cons (nth parts 0)
              (split-all-helper (nth parts 1) char)))))

(defun take (n xs)
  "Take, and return, the first N items from the given list."
  (cond
    ((< n 1) nil)
    ((nil? xs) nil)
    (t (cons (car xs) (take (- n 1) (cdr xs))))))

(defun union (lst1 lst2)
  "Return the list of all distinct values from the two lists, with no duplicates."
  (reverse (union-helper (append lst1 lst2) nil)))

(defun union-helper (xs seen)
  (cond
    ((null? xs) seen)
    ((member? seen (car xs)) (union-helper (cdr xs) seen))
    (t (union-helper (cdr xs) (cons (car xs) seen)))))



;;; 8. System functions.
;;
;; These are functions which are designed to interface with the
;; system environment more than just with File I/O

;; undocumented
(defun lst2array (lst)
  "Convert a lisp list to a C-style array of strings"
  (let ((i 0)
        (n (length lst))
        (m (alloc (* (+ 1 n) 8))))
    (while (< i n)
      (u64! m (* i 8) (nth lst i))
      (set! i (+ i 1)))
    (u64! m (* i 8) 0)
    m))

(defun cd (path)
  "Change to the given working directory"
  (if (< (syscall SYS_chdir path) 0)
    nil 1))

(defun getc ()
  "Read a single character from STDIN, and return it."
  (let ((str "s"))
    (if (> (syscall SYS_read 0 str 1) 0)
      (strat str 0)
     0)))

(defun getenv (name)
  "Return the contents of a given environmental variable.

Uses (environment) to get all environmental variables, and filters."
  (getenv-loop name (environment)))

(defun getenv-loop (name xs)
  (if xs
      (let ((parts (split (car xs) #\=)))
        (if parts
            (if (= (car parts) name)
                (car (cdr parts))
                (getenv-loop name (cdr xs)))
            (getenv-loop name (cdr xs))))
      nil))

(defun getgid ()
  "Return the group ID of the current user."
  (let ((res (syscall SYS_getgid)))
    (if (< res 0)
      nil  res )))

(defun getpid ()
  "Return the process ID of the current process."
  (let ((res (syscall SYS_getpid)))
    (if (< res 0)
      nil  res )))

(defun getuid ()
  "Return the ID of the current user."
  (let ((res (syscall SYS_getuid)))
    (if (< res 0)
      nil  res )))

(defun hostname ()
  "Return the system hostname, via the uname syscall."
  (let ((len 1024)
        (hst "")
        (i 0)
        (buf (alloc len)))
    (if (< (syscall SYS_uname buf len) 0)
        nil
      (do
       (while (!= (strat buf (+ i 65)) 0)
         (set! hst (strcat hst (string (chr (strat buf (+ i 65))))))
         (set! i (+ i 1)))
        hst))))

(defun now ()
  "Return the number of milliseconds since the Unix EPOCH."
  (let ((buffer (alloc 16)))
    (if (< (syscall SYS_clock_gettime 0 buffer) 0)
       nil
       (let ((tv_sec  (u64 buffer 0))
             (tv_nsec (u64 buffer 8)))
             (+ (* tv_sec 1000) (/ tv_nsec 1000000))))))


(defun putc (c)
  "Write the single specified character to STDOUT."
  (cond
    ((str?  c) (syscall 1 1 (substr c 0 1) 1))
    ((char? c) (syscall 1 1 (string c) 1))
    ((int?  c) (syscall 1 1 (string (chr (& 255 c))) 1))
    (t         (do (println "putc called with bogus arg") (exit 1)))))

(defun pwd ()
  "Return the current working directory"
  (let ((len 1024)
        (buf (alloc len)))
    (if (>= (syscall SYS_getcwd buf len) 0)
      buf  nil)))

(defun random (n)
  "Return a random number between zero and N-1, (both zero and N-1 are valid return values.)

See-also random_string."
  (let ((buf "skx/slisp"))
    (syscall SYS_getrandom buf 8)
    (% (abs (u64 buf 0)) n)))

(defun random_string (len)
  "Return a random ASCII string of the given length.

See-also random."
  (let ((choices "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789-_")
        (count   (length choices))
        (txt ""))
    (while (< (length txt) len)
      (let ((c (substr choices (random count) 1)))
       (set! txt (strcat txt c))))
   txt))

(defun read-line ()
  "Read and return a line of text from STDIN.
The newline which terminates input is not included."
  (let ((text "")
        (done nil)
        (ch ""))
    (while (not done)
      (set! ch (getc))
      (if (not ch)
          (set! done t) ; failed to read
          (if (= ch #\Newline)
              (set! done t)
              (set! text (strcat text (string (chr ch)))))))
    text))

;; shell to use for running system commands.
(defvar sys_run_shell "/bin/sh")

;; undocumented
(defun sys_run (command output)
  "Run the given command, under the shell /bin/sh, and capture the output in the named file."
  (let ((pid 0)
        (fd 0)
        (argv nil)
        (status 0))

    (set! pid (syscall SYS_fork))

    (if (< pid 0)
        (do (println "sys_run: fork failed") nil)

        (if (= pid 0)

            ;; Child.
            (do
              (set! fd (syscall SYS_open output 577 420))

              (if (< fd 0)
                  (do (println "sys_run: failed to open output") (syscall SYS_exit 127))

                  (do
                    (syscall SYS_dup2 fd 1)
                    (syscall SYS_dup2 fd 2)
                    (syscall SYS_close fd)

                    (let ((argv (lst2array (list sys_run_shell "-c" command)))
                          (env  (lst2array (environment))))

                      ;; execute
                      (syscall SYS_execve sys_run_shell argv env)

                      ;; execve only returns on failure.
                      (syscall SYS_exit 127)))))
            ;; Parent.
            (do
             (let ((status (alloc 8)))
               (let ((r (syscall SYS_wait4 pid status 0 0)))
                 (u32 status 0))))))))

(defun system(cmd)
  "Run a command and return the output, or nil on failure."
  (let ((suffix  (random_string 8))             ; avoid predictable filenames
        (tmp     (strcat "/tmp/mktmp." suffix)) ; tmp file for output
        (res     (sys_run cmd tmp))             ; run command
        (handle  (fopen tmp "r"))               ; open file
        (data    (fread handle))                ; read output
        (ignore1 (fclose handle))               ; close file
        (ignore2 (unlink tmp)))                 ; delete temporary file
    (if (= 0 res)                               ; return either data, or nil
        data
        nil)))




;;; 9. alist functions.
(require alist)

;;; 10. plist functions.
(require plist)

;;; 11. Conversion functions.
;;
;; Conversion routines - so far just string -> number
;;

(defun atof (str)
  "Convert the given string to a floating point number.

For integer conversion use (atoi) instead."
  (let ((chars (explode str)))
    (cond
      ((= (ord (car chars)) (ord #\-))
       (- 0 (atof-unsigned (implode (cdr chars)))))

      ((= (ord (car chars)) (ord #\+))
       (atof-unsigned (implode (cdr chars))))

      (t
       (atof-unsigned str)))))

(defun atof-frac (chars value scale)
  (if (nil? chars)
      (/ value (+ scale 0.0))
      (atof-frac
       (cdr chars)
       (+ (* value 10)
          (- (ord (car chars))
             (ord #\0)))
       (* scale 10))))

(defun atof-unsigned (str)
  (let ((parts (split str #\.)))
    (if (nil? parts)

        ;; No decimal point.
        (atoi str)

        ;; Decimal point.
        (+ (atoi (car parts))
           (atof-frac (explode (cadr parts)) 0 1)))))

(defun atoi (str)
  "Convert the given string to an integer.

Positive and negative numbers work. For floats use (atof)."
  (let ((chars (explode str)))
    (if (= (car chars) #\-)
        (- 0 (atoi-helper (cdr chars) 0))
        (atoi-helper chars 0))))

(defun atoi-helper (chars value)
  (if (nil? chars)
      value
      (atoi-helper
       (cdr chars)
       (+ (* value 10)
          (- (ord (car chars))
             (ord #\0))))))

(defun lower (str)
  "Convert the given string to lower-case."
  (implode
   (map
    (lambda (ch)
      (let ((n (ord ch)))
        (if (and (>= n (ord #\A))
                 (<= n (ord #\Z)))
            (chr (+ n 32))
            ch)))
    (explode str))))

(defun upper (str)
  "Convert the given string to upper-case."
  (implode
   (map
    (lambda (ch)
      (let ((n (ord ch)))
        (if (and (>= n (ord #\a))
                 (<= n (ord #\z)))
            (chr (- n 32))
            ch)))
    (explode str))))


;;; 12. Utility functions
;;
;; Some other functions that don't have a natural home

(defun strstr (haystack needle)
  "Find the given substring within the initial string, returns the offset if found, nil otherwise."
  (let ((h (explode haystack))
        (n (explode needle)))
    (strstr-helper h n 0)))

(defun strstr-helper (h n offset)
  (cond
    ((nil? h) nil)
    ((str-prefix? h n) offset)
    (t (strstr-helper (cdr h) n (+ offset 1)))))

(defun str-prefix? (a b)
  (cond
    ((nil? b) t)
    ((nil? a) nil)
    ((= (car a) (car b))
     (str-prefix? (cdr a) (cdr b)))
    (t nil)))

(defun substr (str start &len)
  "Return a substring of the given string.

If no length is specified return from the given start to the end of the string."
  (if len
      (sys_substr str start (car len))
      (sys_substr str start (- (length str) start))))

;; Declare an "at_exit" function, this is called *after* main terminates
;;
;; It is expected the user will override this, if they want to.
(defun at_exit ()
   ;; NOP
  (if (> (length (getenv "GC_DUMP_STATS")) 0)
      (let ((bytes (sys-heap-bytes))  ; bytes
            (size  (lambda (n)
                     (let ((suffix " bytes"))        ; with a suffix
                       (when (> n 1024)
                         (set! n (/ n 1024))
                         (set! suffix "K"))
                       (when (> n 1024)
                         (set! n (/ n 1024))
                         (set! suffix "M"))
                       (when (> n 1024)
                         (set! n (/ n 1024))
                         (set! suffix "G"))
                       (strcat (string n) suffix)))))

        (println "\theap objects:" (sys-heap-objects))
        (println "\theap size:" (size bytes) " allocation-limit:" (sys-gc-threshold))
        (println "\tallocations:" (sys-heap-allocs)))))


;; We're loaded now.
(defvar *stdlib* (sys-stdlib-loaded))