mirror of
https://github.com/open-goal/jak-project.git
synced 2024-10-20 21:27:52 -04:00
356 lines
7.7 KiB
Scheme
356 lines
7.7 KiB
Scheme
;-*-Scheme-*-
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; LEXICAL STUFF
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; Bind vars in body
|
|
(defmacro let (bindings &rest body)
|
|
`((lambda :inline-only #t ,(apply first bindings) ,@body)
|
|
,@(apply second bindings)))
|
|
|
|
;; Let, but recursive, allowing you to define variables in terms of others.
|
|
(defmacro let* (bindings &rest body)
|
|
(if (null? bindings)
|
|
`(begin ,@body)
|
|
`((lambda :inline-only #t (,(caar bindings))
|
|
(let* ,(cdr bindings) ,@body))
|
|
,(car (cdar bindings))
|
|
)
|
|
)
|
|
)
|
|
|
|
;; Backup some values, and restore after executing body.
|
|
;; Non-dynamic (nonlocal jumps out of body will skip restore)
|
|
(defmacro protect (defs &rest body)
|
|
(if (null? defs)
|
|
;; nothing to backup, just insert body (base case)
|
|
`(begin ,@body)
|
|
|
|
;; a unique name for the thing we are backing up
|
|
(with-gensyms (backup)
|
|
;; store the original value of the first def in backup
|
|
`(let ((,backup ,(first defs)))
|
|
;; backup any other things which need backing up
|
|
(protect ,(cdr defs)
|
|
;; execute the body
|
|
,@body
|
|
)
|
|
;; restore the first thing
|
|
(set! ,(first defs) ,backup)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; DEFINE STUFF
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; Define a new function
|
|
(defmacro defun (name bindings &rest body)
|
|
(if (and
|
|
(> (length body) 1) ;; more than one thing in function
|
|
(string? (first body)) ;; first thing is a string
|
|
)
|
|
;; then it's a docstring and we ignore it.
|
|
`(define ,name (lambda :name ,name ,bindings ,@(cdr body)))
|
|
;; otherwise don't ignore it.
|
|
`(define ,name (lambda :name ,name ,bindings ,@body))
|
|
)
|
|
)
|
|
|
|
;; Define a new function, but only if we're debugging.
|
|
;; TODO - should place the function in the debug segment!
|
|
(defmacro defun-debug (name &rest args)
|
|
`(if *debug-segment*
|
|
(defun ,name ,@args) ;; debug data is loaded, define function in symbol table
|
|
(define ,name nothing) ;; function not loaded, set function to the nothing function.
|
|
)
|
|
)
|
|
|
|
;; By default, recursive functions don't work because the compiler doesn't
|
|
;; know the return type of a function until after the function is fully defined.
|
|
;; To get around this, this macro allows you to define a function + give a return type.
|
|
;; it simply forward declares the function with the given return, then defines the function as normal
|
|
;; if you got the return type wrong, the function definition conflicts with the forward dec
|
|
;; and throws an error.
|
|
(defmacro defun-recursive (name bindings return-type &rest body)
|
|
`(begin
|
|
(defun-extern ,name ,bindings ,return-type)
|
|
(define ,name (lambda :name ,name ,bindings
|
|
;; omit the doc-string if needed
|
|
,@(if (and (> (length body) 1) (string? (first body)))
|
|
(cdr body)
|
|
body
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; CONDITIONAL COMPILATION
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(defmacro #when (clause &rest body)
|
|
`(#cond (,clause ,@body))
|
|
)
|
|
|
|
(defmacro #unless (clause &rest body)
|
|
`(#cond ((not ,clause) ,@body))
|
|
)
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; MATH STUFF
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(defmacro +1 (var)
|
|
`(+ ,var 1)
|
|
)
|
|
|
|
(defmacro +! (place amount)
|
|
`(set! ,place (+ ,place ,amount))
|
|
)
|
|
|
|
(defmacro +1! (place)
|
|
`(set! ,place (+ 1 ,place))
|
|
)
|
|
|
|
(defmacro -! (place amount)
|
|
`(set! ,place (- ,place ,amount))
|
|
)
|
|
|
|
(defmacro *! (place amount)
|
|
`(set! ,place (* ,place ,amount))
|
|
)
|
|
|
|
(defmacro 1- (var)
|
|
`(- ,var 1)
|
|
)
|
|
|
|
(defmacro fabs (x)
|
|
`(if (> 0.0 ,x) (- ,x) ,x)
|
|
)
|
|
|
|
(defmacro fmin (a b)
|
|
`(if (> ,a ,b) ,b ,a)
|
|
)
|
|
|
|
(defmacro fmax (a b)
|
|
`(if (> ,a ,b) ,a ,b)
|
|
)
|
|
|
|
|
|
(defmacro true! (place)
|
|
`(set! ,place #t)
|
|
)
|
|
|
|
(defmacro false! (place)
|
|
`(set! ,place #f)
|
|
)
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; CONTROL FLOW STUFF
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(defmacro if (condition true-case &rest others)
|
|
(if (null? others)
|
|
`(cond (,condition ,true-case))
|
|
`(cond (,condition ,true-case)
|
|
(else ,(first others))
|
|
)
|
|
)
|
|
)
|
|
|
|
(defmacro when (condition &rest body)
|
|
`(if ,condition
|
|
(begin ,@body)
|
|
)
|
|
)
|
|
|
|
(defmacro unless (condition &rest body)
|
|
`(if (not ,condition)
|
|
(begin ,@body)
|
|
)
|
|
)
|
|
|
|
|
|
; (defmacro while (test &rest body)
|
|
; (with-gensyms (reloop test-exit)
|
|
; `(begin
|
|
; (goto ,test-exit)
|
|
; (label ,reloop)
|
|
; ,@body
|
|
; (label ,test-exit)
|
|
; (when ,test
|
|
; (goto ,reloop)
|
|
; )
|
|
; )
|
|
; )
|
|
; )
|
|
|
|
(defmacro while (test &rest body)
|
|
(with-gensyms (reloop test-exit)
|
|
`(begin
|
|
(goto ,test-exit)
|
|
(label ,reloop)
|
|
,@body
|
|
(label ,test-exit)
|
|
(when-goto ,test ,reloop)
|
|
#f
|
|
)
|
|
)
|
|
)
|
|
|
|
|
|
(defmacro and (&rest args)
|
|
(with-gensyms (result end)
|
|
`(begin
|
|
(let ((,result (the object #f)))
|
|
,@(apply (lambda (x)
|
|
`(begin
|
|
(set! ,result ,x)
|
|
(if (eq? ,result #f)
|
|
(goto ,end)
|
|
)
|
|
)
|
|
)
|
|
args
|
|
)
|
|
(label ,end)
|
|
,result
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|
|
(defmacro or (&rest args)
|
|
(with-gensyms (result end)
|
|
`(begin
|
|
(let ((,result (the object #f)))
|
|
,@(apply (lambda (x)
|
|
`(begin
|
|
(set! ,result ,x)
|
|
(if (not (eq? ,result #f))
|
|
(goto ,end)
|
|
)
|
|
)
|
|
)
|
|
args
|
|
)
|
|
(label ,end)
|
|
,result
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|
|
(defmacro zero? (thing)
|
|
`(eq? ,thing 0)
|
|
)
|
|
|
|
(defmacro until (test &rest body)
|
|
(with-gensyms (reloop)
|
|
`(begin
|
|
(label ,reloop)
|
|
,@body
|
|
(when-goto (not ,test) ,reloop)
|
|
; (when (not ,test)
|
|
; (goto ,reloop)
|
|
; )
|
|
)
|
|
)
|
|
)
|
|
|
|
(defmacro dotimes (var &rest body)
|
|
`(let (( ,(first var) 0))
|
|
(while (< ,(first var) ,(second var))
|
|
,@body
|
|
(+1! ,(first var))
|
|
)
|
|
,@(cddr var)
|
|
)
|
|
)
|
|
|
|
(defmacro countdown (var &rest body)
|
|
`(let ((,(first var) ,(second var)))
|
|
(while (!= ,(first var) 0)
|
|
(set! ,(first var) (- ,(first var) 1))
|
|
,@body
|
|
)
|
|
)
|
|
)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; TYPE STUFF
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(defmacro basic? (obj)
|
|
;; todo, make this more efficient
|
|
`(= 4 (logand (the integer ,obj) #b111))
|
|
)
|
|
|
|
(defmacro pair? (obj)
|
|
;; todo, make this more efficient
|
|
`(= 2 (logand (the integer ,obj) #b111))
|
|
)
|
|
|
|
(defmacro binteger? (obj)
|
|
`(zero? (logand (the integer ,obj) #b111))
|
|
)
|
|
|
|
(defmacro rtype-of (obj)
|
|
`(cond ((binteger? ,obj) binteger)
|
|
((pair? ,obj) pair)
|
|
(else (-> (the basic ,obj) type))
|
|
)
|
|
)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; PAIR STUFF
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
|
|
(defmacro cons (a b)
|
|
`(new 'global 'pair ,a ,b)
|
|
)
|
|
|
|
|
|
(defmacro list (&rest args)
|
|
(if (null? args)
|
|
(quote '())
|
|
`(cons ,(car args) (list ,@(cdr args)))
|
|
)
|
|
)
|
|
|
|
(defmacro null? (arg)
|
|
;; todo, make this better
|
|
`(if (eq? ,arg '())
|
|
#t
|
|
#f
|
|
)
|
|
)
|
|
|
|
(defmacro caar (arg)
|
|
`(car (car ,arg))
|
|
)
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; METHOD STUFF
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
|
|
(defmacro object-new (&rest sz)
|
|
(if (null? sz)
|
|
`(the ,(current-method-type) ((-> object methods 0) allocation type-to-make (-> type-to-make asize)))
|
|
`(the ,(current-method-type) ((-> object methods 0) allocation type-to-make ,@sz))
|
|
)
|
|
)
|
|
|