mirror of
https://github.com/open-goal/jak-project
synced 2026-08-17 13:40:39 -04:00
add old goal tests, just as a reference
This commit is contained in:
water
@@ -0,0 +1,44 @@
|
||||
;-*-Scheme-*-
|
||||
|
||||
;; This file is loaded as part of goal-lib.gc.
|
||||
;; It should generate no code.
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; COMPILER CONTROL
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;; TODO change me!!!
|
||||
(defglobalconstant *compiler-output-path* "obj/")
|
||||
|
||||
;; a macro to compile the test file
|
||||
(defmacro :t ()
|
||||
`(asm-file "game/test.gc" :color)
|
||||
)
|
||||
|
||||
;; a macro to compile and load the test file
|
||||
(defmacro :tl ()
|
||||
`(asm-file "game/test.gc" :color :load)
|
||||
)
|
||||
|
||||
;; compile the gcommon code.
|
||||
(defmacro :g ()
|
||||
;`(asm-file "game/kernel/gcommon.gc" :color :write)
|
||||
`(asm-file "game/kernel/gcommon.gc" :color)
|
||||
)
|
||||
|
||||
;; compile and load the gcommon code.
|
||||
(defmacro :gl ()
|
||||
`(begin
|
||||
(asm-file "game/kernel/gcommon.gc" :color :load)
|
||||
)
|
||||
)
|
||||
|
||||
;; compile, color, and save a file
|
||||
(defmacro m (file)
|
||||
`(asm-file ,file :color :write)
|
||||
)
|
||||
|
||||
;; compile, color, load and save a file
|
||||
(defmacro ml (file)
|
||||
`(asm-file ,file :color :load :write)
|
||||
)
|
||||
@@ -0,0 +1,7 @@
|
||||
;-*-Scheme-*-
|
||||
|
||||
;; This file is loaded as part of goal-lib.gc.
|
||||
;; It should generate no code.
|
||||
|
||||
(defglobalconstant M_PI 3.1415926589932)
|
||||
(defglobalconstant *gtype-basic-offset* 4)
|
||||
@@ -0,0 +1,96 @@
|
||||
;-*-Scheme-*-
|
||||
|
||||
;; This file is loaded as part of goal-lib.gc.
|
||||
;; It should generate no code.
|
||||
|
||||
;; This is used to extern define all C Kernel functions and types.
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Forward declare C Kernel Fixed Syms
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; '()
|
||||
|
||||
;; booleans
|
||||
(define-extern #f boolean)
|
||||
(define-extern #t boolean)
|
||||
|
||||
;; types
|
||||
(define-extern function type)
|
||||
(define-extern symbol type)
|
||||
(define-extern basic type)
|
||||
(define-extern string type)
|
||||
(define-extern type type)
|
||||
(define-extern object type)
|
||||
(define-extern link-block type)
|
||||
(define-extern integer type)
|
||||
(define-extern sinteger type)
|
||||
(define-extern uinteger type)
|
||||
(define-extern binteger type)
|
||||
(define-extern int8 type)
|
||||
(define-extern int16 type)
|
||||
(define-extern int32 type)
|
||||
(define-extern int64 type)
|
||||
(define-extern int128 type)
|
||||
(define-extern uint8 type)
|
||||
(define-extern uint16 type)
|
||||
(define-extern uint32 type)
|
||||
(define-extern uint64 type)
|
||||
(define-extern uint128 type)
|
||||
(define-extern float type)
|
||||
(define-extern process-tree type)
|
||||
(define-extern process type)
|
||||
(define-extern thread type)
|
||||
(define-extern structure type)
|
||||
(define-extern pair type)
|
||||
(define-extern pointer type)
|
||||
(define-extern number type)
|
||||
(define-extern array type)
|
||||
(define-extern vu-function type)
|
||||
(define-extern connectable type)
|
||||
(define-extern stack-frame type)
|
||||
(define-extern file-stream type)
|
||||
(define-extern kheap type)
|
||||
|
||||
;; functions
|
||||
(defun-extern nothing () none)
|
||||
;; del basic
|
||||
(define-extern static symbol)
|
||||
(define-extern global object)
|
||||
;;(define-extern debug kheap)
|
||||
(define-extern loading-level symbol)
|
||||
(define-extern loading-package symbol)
|
||||
(define-extern process-level-heap symbol)
|
||||
(define-extern stack symbol)
|
||||
(define-extern scratch symbol)
|
||||
|
||||
;;(define-extern *scratch-top* pointer)
|
||||
(defun-extern zero-func () int32)
|
||||
(defun-extern method-set! ((x type) (y integer) (z function)) object)
|
||||
;; todo - change allocation to a kheap
|
||||
(defun-extern dgo-load ((name string) (allocation object) (flag integer) (buffer-size integer)) none)
|
||||
|
||||
(defun-extern *listener-function* () object)
|
||||
(define-extern *enable-method-set* int32)
|
||||
;; asizeo-of-bsic
|
||||
;; copy-basic
|
||||
;; level
|
||||
;; art group
|
||||
;; tx page dir
|
||||
;; tx page
|
||||
;; sound
|
||||
;; dgo
|
||||
;; top level
|
||||
|
||||
(defun-extern string->symbol ((x string)) symbol)
|
||||
(defun-extern print ((x object)) object)
|
||||
(defun-extern inspect ((x object)) object)
|
||||
(define-extern test-function function)
|
||||
(define-extern _format function)
|
||||
;; for the compiler
|
||||
(define-extern format function)
|
||||
;; TODO - some others...
|
||||
(define-extern *kernel-boot-message* symbol)
|
||||
(define-extern *debug-segment* boolean)
|
||||
|
||||
;; for use by the compiler.
|
||||
(defun-extern malloc ((allocation symbol) (size integer)) pointer)
|
||||
@@ -0,0 +1,100 @@
|
||||
;-*-Scheme-*-
|
||||
|
||||
;; THE GOAL COMMON LIBRARY
|
||||
;; before this is loaded into the compiler, GOOS needs to have loaded
|
||||
;; goos-lib.gs. The goos-lib will insert some macros into GOAL's macro space
|
||||
;; required for this to work.
|
||||
|
||||
;; WARNING - this file should generate NO CODE!
|
||||
;; Any code which would be generated by this file is thrown out without warning!
|
||||
;; Any "common" code should go in gcommon instead.
|
||||
|
||||
(asm-file "goal/gc/goal-test-defs.gc")
|
||||
(asm-file "goal/gc/goal-target-control.gc")
|
||||
(asm-file "goal/gc/goal-compiler-control.gc")
|
||||
(asm-file "goal/gc/goal-syntax.gc")
|
||||
(asm-file "goal/gc/goal-test-utils.gc")
|
||||
(asm-file "goal/gc/goal-externs.gc")
|
||||
(asm-file "goal/gc/goal-constants.gc")
|
||||
(asm-file "goal/gc/goal-macros.gc")
|
||||
(asm-file "builder/gc/builder.gc")
|
||||
|
||||
;; Ideally this file only contains the above asm-file statements
|
||||
;; but below is a good spot for temporary hacks:
|
||||
|
||||
|
||||
;; HACKS!
|
||||
|
||||
;; temp hack, this gets you the wrong type, and doesn't do good typechecking on the inputs
|
||||
; (defmacro &+ (v1 v2)
|
||||
; `(the pointer (+ (the integer ,v1) (the integer ,v2)))
|
||||
; )
|
||||
|
||||
(defmacro &+ (v1 &rest args)
|
||||
(if (null? args)
|
||||
`(the pointer ,v1)
|
||||
`(&+ (+ (the integer ,v1) (the integer ,(first args))) ,@(cdr args))
|
||||
)
|
||||
)
|
||||
|
||||
(defmacro &- (v1 v2)
|
||||
`(the pointer (- (the integer ,v1) (the integer ,v2)))
|
||||
)
|
||||
|
||||
(defmacro &+! (v1 v2)
|
||||
`(set! ,v1 (&+ ,v1 ,v2))
|
||||
)
|
||||
|
||||
;; macro to print a float.
|
||||
(defmacro pf (flt)
|
||||
`(format #t "~f~%" ,flt)
|
||||
)
|
||||
|
||||
(defmacro ct ()
|
||||
;; compiler test
|
||||
`(begin
|
||||
(build-game)
|
||||
(set! fancy-listener-print #f)
|
||||
(test)
|
||||
(set! fancy-listener-print #t)
|
||||
)
|
||||
)
|
||||
|
||||
(defmacro tt ()
|
||||
`(begin
|
||||
(lt)
|
||||
(asm-file "game/test.gc" :color :load)
|
||||
)
|
||||
)
|
||||
|
||||
(defmacro tn ()
|
||||
`(begin
|
||||
(asm-file "game/test.gc" :color)
|
||||
)
|
||||
)
|
||||
|
||||
|
||||
(defmacro lm ()
|
||||
`(begin
|
||||
(build-game)
|
||||
(asm-file "game/engine/math/math.gc" :color :load)
|
||||
(set! fancy-listener-print #t)
|
||||
)
|
||||
)
|
||||
|
||||
(defmacro lg ()
|
||||
`(begin
|
||||
(dgo-load "game" global #xf #x200000)
|
||||
))
|
||||
|
||||
(defmacro e ()
|
||||
`(:exit)
|
||||
)
|
||||
|
||||
;(test)
|
||||
;; uncomment to run tests automatically on startup.
|
||||
;; Useful for running the compiler in GDB where you can't easily type stuff.
|
||||
;;:(:t)
|
||||
;(build-game)
|
||||
|
||||
; (set-config! debug-print-obj #t)
|
||||
@@ -0,0 +1,23 @@
|
||||
;-*-Scheme-*-
|
||||
|
||||
;; This file is loaded as part of goal-lib.gc.
|
||||
;; It should generate no code.
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; BIT STUFF
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defmacro align16 (value)
|
||||
`(logand #xfffffff0 (+ (the integer ,value) 15))
|
||||
)
|
||||
|
||||
(defmacro &-> (&rest args)
|
||||
`(& (-> ,@args))
|
||||
)
|
||||
|
||||
(defmacro new-with-method (alloc type &rest args)
|
||||
`(the ,type ((-> ,type methods 0) ,alloc ,type ,@args))
|
||||
)
|
||||
|
||||
(defmacro symbol? (basic-obj)
|
||||
`(eq? (-> ,basic-obj type) symbol)
|
||||
)
|
||||
@@ -0,0 +1,355 @@
|
||||
;-*-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))
|
||||
)
|
||||
)
|
||||
|
||||
@@ -0,0 +1,30 @@
|
||||
;-*-Scheme-*-
|
||||
|
||||
;; GOAL Macros for interfacing with the target.
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; TARGET CONTROL
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(defmacro lt (&rest args)
|
||||
;; shortcut for listen-to-target. also sends a :status command to make sure
|
||||
;; all buffers on the target are flushed.
|
||||
`(begin
|
||||
(listen-to-target ,@args)
|
||||
(:status)
|
||||
)
|
||||
)
|
||||
|
||||
(defmacro :r (&rest args)
|
||||
;; shortcut to completely reset the target and connect, regardless of current state
|
||||
`(begin
|
||||
;; connect, so we can send reset. if we're already connected, does nothing
|
||||
(listen-to-target ,@args)
|
||||
;; send a reset message, disconnecting us
|
||||
(reset-target)
|
||||
;; establish connection again
|
||||
(listen-to-target ,@args)
|
||||
;; flush buffers
|
||||
(:status)
|
||||
)
|
||||
)
|
||||
@@ -0,0 +1,134 @@
|
||||
;; Definition of all GOAL tests
|
||||
|
||||
(defglobalconstant *goal-test-prefix* "goal/gc/tests/")
|
||||
(defglobalconstant *goal-test-files*
|
||||
(
|
||||
"test-return-integer.gc"
|
||||
"test-return-integer1.gc"
|
||||
"test-return-integer2.gc"
|
||||
"test-return-integer3.gc"
|
||||
"test-return-integer4.gc"
|
||||
"test-return-integer5.gc"
|
||||
"test-return-integer6.gc"
|
||||
"test-return-negative-integer.gc"
|
||||
"test-conditional-compilation.gc"
|
||||
"test-conditional-compilation-2.gc"
|
||||
"test-define-1.gc"
|
||||
"test-nested-blocks-1.gc"
|
||||
;; up to here has been hand-checked for good code.
|
||||
|
||||
"test-nested-blocks-2.gc"
|
||||
"test-nested-blocks-3.gc"
|
||||
"test-goto-1.gc"
|
||||
"test-defglobalconstant-1.gc"
|
||||
"test-defglobalconstant-2.gc"
|
||||
"test-simple-function-call.gc"
|
||||
"test-application-lambda-1.gc"
|
||||
"test-let-1.gc"
|
||||
"test-let-star-1.gc"
|
||||
"test-string-constant-1.gc"
|
||||
"test-string-constant-2.gc"
|
||||
"test-defun-return-constant.gc"
|
||||
"test-defun-return-symbol.gc"
|
||||
"test-function-return-arg-1.gc"
|
||||
"test-nested-function-call.gc"
|
||||
"test-add-int-constants.gc"
|
||||
"test-add-int-vars.gc"
|
||||
"test-add-int-multiple.gc"
|
||||
"test-add-int-multiple-2.gc"
|
||||
"test-add-function-returns.gc"
|
||||
"test-sub-1.gc"
|
||||
"test-sub-2.gc"
|
||||
"test-mul-1.gc"
|
||||
"test-declare-inline.gc"
|
||||
"test-inline-call.gc"
|
||||
"test-with-inline.gc"
|
||||
"test-three-reg-add.gc"
|
||||
"test-three-reg-sub.gc"
|
||||
"test-three-reg-mult.gc"
|
||||
"test-mlet.gc"
|
||||
"test-set-symbol.gc"
|
||||
"test-defun-extern.gc"
|
||||
"test-defsmacro-defgmacro.gc"
|
||||
"test-desfun.gc"
|
||||
"test-factorial-recursive.gc"
|
||||
"test-factorial-iterative.gc"
|
||||
"test-div-1.gc"
|
||||
"test-div-2.gc"
|
||||
"test-protect.gc"
|
||||
"test-shiftvs.gc"
|
||||
"test-ash.gc"
|
||||
"test-negative-integer-symbol.gc"
|
||||
"test-mod.gc"
|
||||
"test-nested-function-call-2.gc"
|
||||
"test-load-gcommon.gc"
|
||||
"test-quote-symbol.gc"
|
||||
"test-min-max.gc"
|
||||
"test-format-1.gc"
|
||||
"test-float-product.gc"
|
||||
"test-float-in-symbol.gc"
|
||||
"test-function-return-constant-float.gc"
|
||||
"test-float-function.gc"
|
||||
"test-float-pow-function.gc"
|
||||
"test-bfloat-1.gc"
|
||||
"test-align16-1.gc"
|
||||
"test-align16-2.gc"
|
||||
"test-basic-type-check.gc"
|
||||
"test-return-from-f.gc"
|
||||
"test-return-from-f-tricky-color.gc"
|
||||
"test-signed-int-compare.gc"
|
||||
"test-condition-boolean.gc"
|
||||
"test-return-value-of-if.gc"
|
||||
"test-inline-array-field.gc"
|
||||
"test-access-inline-array.gc"
|
||||
"test-find-parent-method.gc"
|
||||
"test-empty-pair.gc"
|
||||
"test-pairp.gc"
|
||||
"test-cons.gc"
|
||||
"test-list.gc"
|
||||
"test-car-cdr-get.gc"
|
||||
"test-car-cdr-set.gc"
|
||||
"test-nested-car-cdr-set.gc"
|
||||
"test-dotimes.gc"
|
||||
"test-ref.gc"
|
||||
"test-pair-asize.gc"
|
||||
"test-last.gc"
|
||||
"test-pair-length.gc"
|
||||
"test-member-1.gc"
|
||||
"test-member-2.gc"
|
||||
"test-assoc-1.gc"
|
||||
"test-assoc-2.gc"
|
||||
"test-assoce-1.gc"
|
||||
"test-assoce-2.gc"
|
||||
"test-append.gc"
|
||||
"test-delete-list.gc"
|
||||
"test-delete-car.gc"
|
||||
"test-insert-cons.gc"
|
||||
"test-sort.gc"
|
||||
"test-new-inline-array-class.gc"
|
||||
"test-pointer-as-array-numbers.gc"
|
||||
"test-memcpy.gc"
|
||||
"test-qmemcpy-down.gc"
|
||||
"test-qmemcpy-up.gc"
|
||||
"test-memset.gc"
|
||||
"test-print-binteger.gc"
|
||||
"test-type-arrays.gc"
|
||||
"test-number-comparison.gc"
|
||||
"test-approx-pi.gc"
|
||||
"test-dynamic-type.gc"
|
||||
"test-string-type.gc"
|
||||
"test-new-string.gc"
|
||||
"test-static-new-integer-field.gc"
|
||||
"test-addr-of.gc"
|
||||
"test-set-self.gc"
|
||||
"test-asm-func.gc"
|
||||
"test-methods.gc"
|
||||
"test-bitfield-enums.gc"
|
||||
"test-packed-inline-array.gc"
|
||||
"test-fixed-shifts.gc"
|
||||
"test-add-binteger.gc"
|
||||
"test-bitfield-access.gc"
|
||||
"test-bitfield-set1.gc"
|
||||
)
|
||||
)
|
||||
|
||||
@@ -0,0 +1,39 @@
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; COMPILER TEST
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;; macro to set up the target and compiler for a test
|
||||
(defmacro test-setup (expected-value reset-required)
|
||||
`(begin
|
||||
;; first, reboot and connect
|
||||
;; this uses a "compile time" conditional, as (:r) does the reset when it is _compiled_.
|
||||
;; so we want to compile the (:r) only if the reset is wanted.
|
||||
(#when ,reset-required (:r))
|
||||
;; set expected value in GOOS
|
||||
(seval (define *test-expected* ,expected-value))
|
||||
;; make sure that *test-result* is an object to avoid typing errors with future tests.
|
||||
(define-extern *test-result* object)
|
||||
)
|
||||
)
|
||||
|
||||
(defmacro test-result (value)
|
||||
value)
|
||||
|
||||
(defmacro expect (v1 v2)
|
||||
`(if (not (eq? ,v1 ,v2))
|
||||
(format #t "TEST FAILURE!~%")
|
||||
)
|
||||
)
|
||||
|
||||
(defmacro expect-true (value)
|
||||
`(if (not (eq? ,value #t))
|
||||
(format #t "TEST FAILTURE!~%")
|
||||
)
|
||||
)
|
||||
|
||||
|
||||
(defmacro expect-false (value)
|
||||
`(if (not (eq? ,value #f))
|
||||
(format #t "TEST FAILTURE!~%")
|
||||
)
|
||||
)
|
||||
@@ -0,0 +1,19 @@
|
||||
;-*-Scheme-*-
|
||||
|
||||
(test-setup 1.2345 #f)
|
||||
|
||||
(let* ((new-method (-> bfloat methods 0))
|
||||
(print-method (-> bfloat methods 2))
|
||||
(my-float (the bfloat (new-method 'global bfloat)))
|
||||
)
|
||||
(set! (-> my-float data) 1.23456)
|
||||
(print-method my-float)
|
||||
(format #t "~%")
|
||||
)
|
||||
|
||||
(let ((x 0))
|
||||
(while (< x 9)
|
||||
(format #t "method ~d of ~A is ~A~%" x bfloat (-> bfloat methods x))
|
||||
(+1! x)
|
||||
)
|
||||
)
|
||||
@@ -0,0 +1,3 @@
|
||||
(test-setup -13 #f)
|
||||
|
||||
(printl (+ (the binteger -3) -10))
|
||||
@@ -0,0 +1,23 @@
|
||||
;-*-Scheme-*-
|
||||
|
||||
;; various functions which add numbers, called in a big sum.
|
||||
(test-setup 21 #f)
|
||||
|
||||
(defun return-one ()
|
||||
1)
|
||||
|
||||
(defun return-sum ((a integer) (b integer))
|
||||
(+ a b)
|
||||
)
|
||||
|
||||
(defun return-plus-two ((in integer))
|
||||
(+ in 2)
|
||||
)
|
||||
|
||||
(defun return-plus-three ((in integer))
|
||||
(+ 3 in)
|
||||
)
|
||||
|
||||
(+ 2 (return-one) (return-plus-three 2) (return-plus-two 3) (return-sum 1 2) (return-plus-two 3))
|
||||
|
||||
|
||||
@@ -0,0 +1,8 @@
|
||||
;-*-Scheme-*-
|
||||
|
||||
;; add two constants together.
|
||||
(test-setup 13 #f)
|
||||
|
||||
(+ 15 -2)
|
||||
|
||||
|
||||
@@ -0,0 +1,19 @@
|
||||
;-*-Scheme-*-
|
||||
|
||||
(test-setup 15 #f)
|
||||
|
||||
;; add a bunch of numbers together in a single function, in a strange order.
|
||||
|
||||
(defun add-five-v2 ((a int32) (b int32) (c int32) (d int32) (e int32))
|
||||
(let* ((total-1 a)
|
||||
(also-d d)
|
||||
(total-2 (+ total-1 b))
|
||||
(total-3 (+ c total-2))
|
||||
)
|
||||
(+ total-3 e also-d)
|
||||
)
|
||||
)
|
||||
|
||||
(add-five 1 2 3 4 5)
|
||||
|
||||
|
||||
@@ -0,0 +1,13 @@
|
||||
;-*-Scheme-*-
|
||||
|
||||
(test-setup 15 #f)
|
||||
|
||||
;; add a bunch of numbers together in a single function.
|
||||
|
||||
(defun add-five ((a integer) (b integer) (c integer) (d integer) (e integer))
|
||||
(+ c d (+ e a) b)
|
||||
)
|
||||
|
||||
(add-five 1 2 3 4 5)
|
||||
|
||||
|
||||
@@ -0,0 +1,13 @@
|
||||
;-*-Scheme-*-
|
||||
|
||||
(test-setup 7 #f)
|
||||
|
||||
;; add two numbers in a function
|
||||
|
||||
(defun add-two ((x integer) (y integer))
|
||||
(+ x y)
|
||||
)
|
||||
|
||||
(add-two 3 4)
|
||||
|
||||
|
||||
@@ -0,0 +1,13 @@
|
||||
(test-setup 4 #f)
|
||||
|
||||
(deftype addr-of-test-type (basic)
|
||||
((v1 int32 :offset 4)
|
||||
(arr int32 12 :offset 8)
|
||||
)
|
||||
)
|
||||
|
||||
(let ((temp (new 'global 'addr-of-test-type)))
|
||||
(expect-true (= 12 (- (the integer (&-> temp arr 1)) (the integer temp))))
|
||||
(- (the integer (&-> temp v1)) (the integer temp))
|
||||
)
|
||||
|
||||
@@ -0,0 +1,6 @@
|
||||
;-*-Scheme-*-
|
||||
|
||||
|
||||
(test-setup 80 #f)
|
||||
|
||||
(+ (align16 1) (align16 (* 3 5)) (align16 (/ 32 2)) (align16 (- -17)))
|
||||
@@ -0,0 +1,10 @@
|
||||
;-*-Scheme-*-
|
||||
|
||||
|
||||
(test-setup 64 #f)
|
||||
|
||||
(defun type-method-check ((obj type))
|
||||
(align16 (+ 28 (* 4 (-> obj num-methods))))
|
||||
)
|
||||
|
||||
(type-method-check integer)
|
||||
@@ -0,0 +1,4 @@
|
||||
(test-setup '(a b c d e) #f)
|
||||
|
||||
(format #t "~A~%"
|
||||
(append! (list 'a 'b) (list 'c 'd 'e)))
|
||||
@@ -0,0 +1,9 @@
|
||||
;-*-Scheme-*-
|
||||
|
||||
(test-setup 2 #f)
|
||||
|
||||
;; test an immediate lambda which does not generate code.
|
||||
|
||||
(define *test-result*
|
||||
((lambda :inline-only #t (x y z) y) 1 2 3))
|
||||
(test-result *test-result*)
|
||||
@@ -0,0 +1,52 @@
|
||||
|
||||
|
||||
(test-setup 1 #f)
|
||||
|
||||
(defun test-approx-pi ((res integer))
|
||||
(let ((rad (* res res))
|
||||
(count 0))
|
||||
(dotimes (x res)
|
||||
(dotimes (y res)
|
||||
(if (> rad (+ (* x x) (* y y)))
|
||||
(+! count 1)
|
||||
)
|
||||
)
|
||||
)
|
||||
(* 4.0 (/ (the float count) (the float rad)))
|
||||
)
|
||||
)
|
||||
|
||||
(let ((approx-pi (test-approx-pi 1000)))
|
||||
(expect-true (> approx-pi 3.14))
|
||||
(expect-true (< approx-pi 3.15))
|
||||
)
|
||||
|
||||
|
||||
(defun test-approx-pi-float ((res float))
|
||||
(let* ((rad (the float (* res res)))
|
||||
(count (the float 0))
|
||||
(x (the float 0))
|
||||
(y (the float 0))
|
||||
(scale (/ 1.0 rad)))
|
||||
(while (< x res)
|
||||
(set! y 0.0)
|
||||
(while (< y res)
|
||||
; (format #t "tapf ~f ~f ~f~%" x y res)
|
||||
(if (> rad (+ (* x x) (* y y)))
|
||||
(+! count scale)
|
||||
)
|
||||
(+! y 1.0)
|
||||
)
|
||||
(+! x 1.0)
|
||||
)
|
||||
(* 4.0 count)
|
||||
)
|
||||
)
|
||||
|
||||
(let ((approx-pi (test-approx-pi-float 500.0)))
|
||||
(expect-true (> approx-pi 3.14))
|
||||
(expect-true (< approx-pi 3.15))
|
||||
)
|
||||
|
||||
;(format #t "~f~%" (test-approx-pi 1000))
|
||||
1
|
||||
@@ -0,0 +1,13 @@
|
||||
;-*-Scheme-*-
|
||||
|
||||
(test-setup 18 #f)
|
||||
|
||||
(defun ash ((value integer) (shift-amount integer))
|
||||
(if (> shift-amount 0)
|
||||
(shlv value shift-amount)
|
||||
(sarv value (- shift-amount))
|
||||
)
|
||||
)
|
||||
|
||||
(+ (ash (+ 1 2) (/ 6 2)) (ash (- 12) (- 1)))
|
||||
|
||||
@@ -0,0 +1,19 @@
|
||||
(test-setup 1234567 #f)
|
||||
|
||||
(defun test-asm-function ()
|
||||
;; enable asm-func mode (DANGER)
|
||||
(declare (asm-func))
|
||||
;; now we have no prologue/epilogue.
|
||||
;; most operations involving variables are unsafe.
|
||||
|
||||
;; create a "safe" variable which is the rax register
|
||||
(rlet ((ret :reg rax :type integer))
|
||||
;; set to a numeric constant
|
||||
(set! ret 1234567)
|
||||
)
|
||||
|
||||
;; and do a return manually
|
||||
(.ret)
|
||||
)
|
||||
|
||||
(test-asm-function)
|
||||
@@ -0,0 +1,7 @@
|
||||
(test-setup 'w #f)
|
||||
|
||||
(format #t "~A~%"
|
||||
(cdr (assoc 'e (list (cons 'a 'b) (cons 'e 'w) (cons 'x 'x)))))
|
||||
|
||||
|
||||
(print-type (assoc 'a '()))
|
||||
@@ -0,0 +1,4 @@
|
||||
(test-setup #f #f)
|
||||
|
||||
(format #t "~A~%"
|
||||
(assoc 'r (list (cons 'a 'b) (cons 'e 'w) (cons 'x 'x))))
|
||||
@@ -0,0 +1,4 @@
|
||||
(test-setup 'x #f)
|
||||
|
||||
(format #t "~A~%"
|
||||
(cdr (assoce 'r (list (cons 'a 'b) (cons 'e 'w) (cons 'else 'x)))))
|
||||
@@ -0,0 +1,4 @@
|
||||
(test-setup 'x #f)
|
||||
|
||||
(format #t "~A~%"
|
||||
(cdr (assoce 'r (list (cons 'a 'b) (cons 'r 'x) (cons 'else 'w)))))
|
||||
@@ -0,0 +1,24 @@
|
||||
;-*-Scheme-*-
|
||||
|
||||
(test-setup '#f#t#t#f#t#f#t#t #f)
|
||||
|
||||
;; awful hack to create a bfloat at #x6000000
|
||||
(define-extern hack-bfloat integer)
|
||||
(define hack-bfloat (+ #x6000000 *gtype-basic-offset*))
|
||||
(define-extern hack-bfloat bfloat)
|
||||
|
||||
|
||||
(format #t "~A~A~A~A"
|
||||
(basic-type? hack-bfloat integer) ;; #f
|
||||
(basic-type? hack-bfloat structure) ;; #t
|
||||
(basic-type? integer type) ;; #t
|
||||
(basic-type? hack-bfloat object) ;; #t
|
||||
)
|
||||
|
||||
(format #t "~A~A~A~A~%"
|
||||
(basic-type? integer basic) ;; t
|
||||
(basic-type? integer integer) ;; #f
|
||||
(basic-type? #f basic) ;; #t
|
||||
(basic-type? inspect function) ;; #t
|
||||
)
|
||||
|
||||
@@ -0,0 +1,35 @@
|
||||
;-*-Scheme-*-
|
||||
|
||||
(test-setup 1.2339 #f)
|
||||
|
||||
;; awful hack to create a bfloat at #x6000000
|
||||
(define-extern hack-bfloat integer)
|
||||
(define hack-bfloat (+ #x6000000 *gtype-basic-offset*))
|
||||
(define-extern hack-bfloat bfloat)
|
||||
|
||||
;; we have to manually set the type field.
|
||||
(set! (-> hack-bfloat type) bfloat)
|
||||
|
||||
;; set the data field
|
||||
(set! (-> hack-bfloat data) 1.234)
|
||||
|
||||
(defun test-print-bfloat ((obj bfloat))
|
||||
(format #t "~f~%" (-> obj data))
|
||||
)
|
||||
|
||||
;; to make test pass
|
||||
;;(format #t "~f~%" (-> hack-bfloat data))
|
||||
(test-print-bfloat hack-bfloat)
|
||||
|
||||
;; try printing it as a basic (should use default basic printer)
|
||||
(format #t "Here's a bfloat ~A~%" hack-bfloat)
|
||||
|
||||
;; or access the field directly and print as float
|
||||
(format #t "Here's (-> flt data) ~f~%" (-> hack-bfloat data))
|
||||
|
||||
;; or inspect it (compiler should generate this method
|
||||
(format #t "Here's its inspect~%~I~%" hack-bfloat)
|
||||
|
||||
(format #t "It's type is `~A`~%" (-> hack-bfloat type))
|
||||
|
||||
|
||||
@@ -0,0 +1,24 @@
|
||||
(test-setup 'fffffffffffff344f213ffffffffffffffff #f)
|
||||
|
||||
(deftype test-bf-type (int32)
|
||||
((f1 int16)
|
||||
(f2 uint8)
|
||||
(f3 int8 :size 3)
|
||||
(f4 uint8 :size 2)
|
||||
(f5 int8 :size 2)
|
||||
)
|
||||
)
|
||||
|
||||
(deftype test-bf-type2 (int64)
|
||||
((f1 int16)
|
||||
(f2 uint8)
|
||||
(f3 float)
|
||||
)
|
||||
)
|
||||
|
||||
(let ((temp (the test-bf-type #xf9f2f344))
|
||||
(temp2 (the test-bf-type2 #x133f456789012345)))
|
||||
(expect-true (< (fabs (- 1.7711 (+ 1.0 (-> temp2 f3)))) 0.002))
|
||||
; (format #t "diff is ~f~%" (fabs (- 1.711 (+ 1.0 (-> temp2 f3)))))
|
||||
(format #t "~X~X~X~X~X~%" (-> temp f1) (-> temp f2) (-> temp f3) (-> temp f4) (-> temp f5))
|
||||
)
|
||||
@@ -0,0 +1,9 @@
|
||||
(test-setup 5 #f)
|
||||
|
||||
(defenum test-bitfield :bitfield #t
|
||||
(one 0)
|
||||
(two 1)
|
||||
(four 2)
|
||||
)
|
||||
|
||||
(test-bitfield one four)
|
||||
@@ -0,0 +1,20 @@
|
||||
(test-setup 50.3432 #f)
|
||||
|
||||
(deftype test-bf-type3 (int64)
|
||||
((f1 uint16 :offset-assert 0)
|
||||
(f2 uint8 :size 7 :offset-assert 16)
|
||||
(f3 float :offset-assert 23)
|
||||
(f4 uint8 :size 1 :offset-assert 55)
|
||||
(f5 uint8 :offset-assert 56)
|
||||
)
|
||||
)
|
||||
|
||||
(let ((temp (the test-bf-type3 #x0)))
|
||||
(set! (-> temp f1) #x12)
|
||||
(set! (-> temp f2) #x13)
|
||||
(set! (-> temp f3) 12.3433)
|
||||
(set! (-> temp f4) #xffffffff) ; will get truncated.
|
||||
(expect-true (eq? 0 (-> temp f5))) ; check it gets truncated
|
||||
(format #t "~f~%" (+ (-> temp f3) (-> temp f2) (-> temp f1) (-> temp f4)))
|
||||
)
|
||||
|
||||
@@ -0,0 +1,8 @@
|
||||
;-*-Scheme-*-
|
||||
|
||||
|
||||
(test-setup 'ab #f)
|
||||
|
||||
(let ((my-pair (cons 'a 'b)))
|
||||
(format #t "~A~A~%" (car my-pair) (cdr my-pair))
|
||||
)
|
||||
@@ -0,0 +1,10 @@
|
||||
;-*-Scheme-*-
|
||||
|
||||
|
||||
(test-setup 'cd #f)
|
||||
|
||||
(let ((my-pair (cons 'a 'b)))
|
||||
(set! (car my-pair) 'c)
|
||||
(set! (cdr my-pair) 'd)
|
||||
(format #t "~A~A~%" (car my-pair) (cdr my-pair))
|
||||
)
|
||||
@@ -0,0 +1,27 @@
|
||||
;-*-Scheme-*-
|
||||
|
||||
(test-setup 4 #f)
|
||||
|
||||
(let ((total 0))
|
||||
(if (true-func)
|
||||
(+! total 1)
|
||||
(+! total 999)
|
||||
)
|
||||
|
||||
(if (false-func)
|
||||
(+! total 999)
|
||||
(+! total 1)
|
||||
)
|
||||
|
||||
(if (not (true-func))
|
||||
(+! total 999)
|
||||
(+! total 1)
|
||||
)
|
||||
|
||||
(if (not (false-func))
|
||||
(+! total 1)
|
||||
(+! total 999)
|
||||
)
|
||||
total
|
||||
)
|
||||
|
||||
@@ -0,0 +1,9 @@
|
||||
;-*-Scheme-*-
|
||||
|
||||
(test-setup 5 #f)
|
||||
|
||||
;; test the #when and #unless macros
|
||||
|
||||
|
||||
(#unless (< 1 2) (/ 0 0))
|
||||
(#when (< 1 2) 5)
|
||||
@@ -0,0 +1,15 @@
|
||||
;-*-Scheme-*-
|
||||
|
||||
(test-setup 3 #f)
|
||||
|
||||
;; test the use of #cond to evaluate goos expressions.
|
||||
|
||||
(#cond
|
||||
((> 2 (+ 2 1))
|
||||
1
|
||||
)
|
||||
|
||||
((< 2 (+ 1 2))
|
||||
3
|
||||
)
|
||||
)
|
||||
@@ -0,0 +1,7 @@
|
||||
;-*-Scheme-*-
|
||||
|
||||
|
||||
(test-setup '(a) #f)
|
||||
|
||||
(printl (cons 'a '()))
|
||||
|
||||
@@ -0,0 +1,14 @@
|
||||
;-*-Scheme-*-
|
||||
|
||||
|
||||
(test-setup 32 #f)
|
||||
|
||||
;; test calling an inline function. doesn't actually verify the call is inline.
|
||||
|
||||
(defun inline-test-function-1 ((x integer))
|
||||
;; inline this function by default.
|
||||
(declare (inline))
|
||||
(* 4 x)
|
||||
)
|
||||
|
||||
(inline-test-function-1 8)
|
||||
@@ -0,0 +1,12 @@
|
||||
;-*-Scheme-*-
|
||||
|
||||
|
||||
(test-setup 17 #f)
|
||||
|
||||
;; test defglobalconstant to define a goal constant
|
||||
|
||||
(defglobalconstant my-constant 12)
|
||||
(defglobalconstant my-constant 17)
|
||||
(defglobalconstant not-my-consant 13)
|
||||
|
||||
my-constant
|
||||
@@ -0,0 +1,15 @@
|
||||
;-*-Scheme-*-
|
||||
|
||||
|
||||
(test-setup 18 #f)
|
||||
|
||||
;; test defglobalconstant to get a goos constant
|
||||
|
||||
(defmacro get-goos-by-name (name)
|
||||
;; do the lookup in the goos global environment
|
||||
(eval name)
|
||||
)
|
||||
|
||||
(defglobalconstant my-constant 18)
|
||||
|
||||
(get-goos-by-name my-constant)
|
||||
@@ -0,0 +1,17 @@
|
||||
;-*-Scheme-*-
|
||||
|
||||
|
||||
(test-setup 17 #f)
|
||||
|
||||
;; test the use of define.
|
||||
|
||||
(define first-var 1)
|
||||
(define second-var 2)
|
||||
(define first-var 12)
|
||||
|
||||
(begin
|
||||
(define first-var 13)
|
||||
(define second-var 12)
|
||||
(define first-var 17)
|
||||
second-var
|
||||
first-var)
|
||||
@@ -0,0 +1,19 @@
|
||||
;-*-Scheme-*-
|
||||
|
||||
(test-setup 20 #f)
|
||||
|
||||
(defsmacro test-macro (x)
|
||||
;; goos macro
|
||||
`(+ ,x 2)
|
||||
)
|
||||
|
||||
(defmacro test-macro (x)
|
||||
;; goal macro which calls a goos macro of the same name
|
||||
(let ((goos-expansion (test-macro x)))
|
||||
`(+ ,goos-expansion 3)
|
||||
)
|
||||
)
|
||||
|
||||
(test-macro 15)
|
||||
|
||||
|
||||
@@ -0,0 +1,7 @@
|
||||
;-*-Scheme-*-
|
||||
|
||||
(test-setup 12345 #f)
|
||||
|
||||
;; this should be defun-extern'd in goal-lib.gc
|
||||
;; and the function is a C Kernel function.
|
||||
(+ (zero-func) 12345)
|
||||
@@ -0,0 +1,16 @@
|
||||
;-*-Scheme-*-
|
||||
|
||||
(test-setup 12 #f)
|
||||
|
||||
(defun return-13 ()
|
||||
13)
|
||||
|
||||
(defun return-12 ()
|
||||
12)
|
||||
|
||||
(defun return-11 ()
|
||||
11)
|
||||
|
||||
(return-12)
|
||||
|
||||
|
||||
@@ -0,0 +1,14 @@
|
||||
;-*-Scheme-*-
|
||||
|
||||
(test-setup 42 #f)
|
||||
|
||||
|
||||
|
||||
(define my-number 36)
|
||||
|
||||
(defun return-my-number ()
|
||||
my-number)
|
||||
|
||||
(define my-number 42)
|
||||
|
||||
(return-my-number)
|
||||
@@ -0,0 +1,11 @@
|
||||
(test-setup '((a . b) (e . f)) #f)
|
||||
|
||||
(let ((my-list (list (cons 'a 'b)
|
||||
(cons 'c 'd)
|
||||
(cons 'e 'f)
|
||||
)
|
||||
))
|
||||
(delete-car! 'c my-list)
|
||||
(format #t "~A~%" my-list)
|
||||
(format #t "~A~%" (assoc 'c my-list))
|
||||
)
|
||||
@@ -0,0 +1,4 @@
|
||||
(test-setup '(a b d e) #f)
|
||||
|
||||
(format #t "~A~%"
|
||||
(delete! 'c (list 'a 'b 'c 'd 'e)))
|
||||
@@ -0,0 +1,15 @@
|
||||
;-*-Scheme-*-
|
||||
|
||||
|
||||
(test-setup 4 #f)
|
||||
|
||||
(desfun square (x)
|
||||
(* x x)
|
||||
)
|
||||
|
||||
|
||||
(defmacro call-square (x)
|
||||
(square x)
|
||||
)
|
||||
|
||||
(call-square 2)
|
||||
@@ -0,0 +1,6 @@
|
||||
;-*-Scheme-*-
|
||||
|
||||
(test-setup 6 #f)
|
||||
|
||||
(+ 1 2 (/ (* 2 5) (+ 1 2)))
|
||||
|
||||
@@ -0,0 +1,14 @@
|
||||
;-*-Scheme-*-
|
||||
|
||||
(test-setup 7 #f)
|
||||
|
||||
;; this computes nothing that we can check, but verifies that the coloring
|
||||
;; doesn't do something crazy when constrained a little strangely
|
||||
(rlet ((x :reg rsp :type int64))
|
||||
(/ x 2)
|
||||
(/ 2 x)
|
||||
)
|
||||
|
||||
(let ((x 30))
|
||||
(+ (/ x 10) 4)
|
||||
)
|
||||
@@ -0,0 +1,11 @@
|
||||
;-*-Scheme-*-
|
||||
|
||||
|
||||
(test-setup 4950 #f)
|
||||
|
||||
(let ((sum 0))
|
||||
(dotimes (i 100 7 8 9 sum)
|
||||
(+! sum i)
|
||||
;;(format #t "iter ~D sum ~D~%" i sum)
|
||||
)
|
||||
)
|
||||
@@ -0,0 +1,58 @@
|
||||
|
||||
(test-setup 1 #f)
|
||||
|
||||
(deftype test-dynamic-type (basic)
|
||||
(
|
||||
(pad0 int16 :offset 0)
|
||||
(allocated-length int32 :offset 4)
|
||||
(data int32 :dynamic :offset 8)
|
||||
(over1 int32 :offset 8)
|
||||
(over2 int32 :offset 12)
|
||||
)
|
||||
)
|
||||
|
||||
|
||||
(defmethod new test-dynamic-type ((allocation symbol) (type-to-make type) (cnt integer))
|
||||
;"Create a new inline-array. Sets the length, allocated-length to cnt. Uses the mysterious heap-base field
|
||||
;of the type-to-make to determine the element size"
|
||||
(let* ((sz (+ (-> type-to-make asize) (* 4 cnt)))
|
||||
(new-object (object-new sz)))
|
||||
;;(format 0 "create sz ~d at #x~X~%" sz new-object)
|
||||
(unless (zero? new-object)
|
||||
(set! (-> new-object allocated-length) cnt)
|
||||
)
|
||||
new-object
|
||||
)
|
||||
)
|
||||
|
||||
(defmethod length test-dynamic-type ((obj test-dynamic-type))
|
||||
;"Get the length of it"
|
||||
(-> obj allocated-length)
|
||||
)
|
||||
|
||||
(defmethod asize-of test-dynamic-type ((obj test-dynamic-type))
|
||||
;"Get the size in memory of it"
|
||||
(+ (-> obj type asize)
|
||||
(* (-> obj allocated-length) 4)
|
||||
)
|
||||
)
|
||||
|
||||
(define test-dynamic-obj
|
||||
(the test-dynamic-type ((-> test-dynamic-type methods 0) 'global test-dynamic-type 40)))
|
||||
|
||||
;(inspect test-dynamic-obj)
|
||||
|
||||
(set! (-> test-dynamic-obj data 0) 12)
|
||||
(set! (-> test-dynamic-obj data 1) 20)
|
||||
;(inspect test-dynamic-obj)
|
||||
|
||||
; (format #t "should be same (~d ~d) (~d ~d)~%" (-> test-dynamic-obj data 0) (-> test-dynamic-obj over1)
|
||||
; (-> test-dynamic-obj data 1) (-> test-dynamic-obj over2))
|
||||
|
||||
(expect-true (= (-> test-dynamic-obj data 0) (-> test-dynamic-obj over1)))
|
||||
(expect-true (= (-> test-dynamic-obj data 1) (-> test-dynamic-obj over2)))
|
||||
|
||||
(set! (-> test-dynamic-obj pad0) 0)
|
||||
(expect-true (= (-> test-dynamic-obj type) test-dynamic-type))
|
||||
(expect-true (= (asize-of test-dynamic-obj) 180))
|
||||
1
|
||||
@@ -0,0 +1,6 @@
|
||||
;-*-Scheme-*-
|
||||
|
||||
(test-setup '() #f)
|
||||
|
||||
(print '())
|
||||
(format #t "~%")
|
||||
@@ -0,0 +1,15 @@
|
||||
;-*-Scheme-*-
|
||||
|
||||
(test-setup 3628800 #f)
|
||||
|
||||
(defun factorial-iterative ((x integer))
|
||||
(let ((result 1))
|
||||
(while (!= x 1)
|
||||
(set! result (* result x))
|
||||
(set! x (- x 1))
|
||||
)
|
||||
result
|
||||
)
|
||||
)
|
||||
|
||||
(factorial-iterative 10)
|
||||
@@ -0,0 +1,15 @@
|
||||
;-*-Scheme-*-
|
||||
|
||||
(test-setup 3628800 #f)
|
||||
|
||||
;; for now, recursive functions need to forward declare so they have their
|
||||
;; return type.
|
||||
(defun-extern factorial-recursive ((x integer)) integer)
|
||||
|
||||
(defun factorial-recursive ((x integer))
|
||||
(cond ((= x 1) x)
|
||||
(else (* x (factorial-recursive (- x 1))))
|
||||
)
|
||||
)
|
||||
|
||||
(factorial-recursive 10)
|
||||
@@ -0,0 +1,27 @@
|
||||
;-*-Scheme-*-
|
||||
|
||||
(test-setup "test pass!" #f)
|
||||
|
||||
(let ((test-result "test fail!"))
|
||||
|
||||
;; first, do one where we get something
|
||||
(if (eq?
|
||||
(-> structure methods 1)
|
||||
(find-parent-method bfloat 1)
|
||||
)
|
||||
(set! test-result "test pass!")
|
||||
)
|
||||
|
||||
;; nothing
|
||||
(if (not (eq?
|
||||
(find-parent-method structure 5)
|
||||
nothing
|
||||
)
|
||||
)
|
||||
(format #t "TEST FAIL~%~%")
|
||||
)
|
||||
|
||||
(print test-result)
|
||||
)
|
||||
|
||||
|
||||
@@ -0,0 +1,4 @@
|
||||
(test-setup 4611686018427387914 #f)
|
||||
|
||||
(+ (shl 2 3) (shl 1 0) (shl 0 4) (shr 2 3) (shr 10 2) (shl -2 1) (sar -16 2) (shr -1 2))
|
||||
;; 16 1 0 0 2 -4 -4
|
||||
@@ -0,0 +1,12 @@
|
||||
;-*-Scheme-*-
|
||||
|
||||
(test-setup 10.152 #f)
|
||||
|
||||
|
||||
(defun float-testing-function ((x float) (y float))
|
||||
(* x y (* x x))
|
||||
)
|
||||
|
||||
(let ((x (float-testing-function (* 1.2 1.2) 3.4)))
|
||||
(format #t "~,,3f~%" x)
|
||||
)
|
||||
@@ -0,0 +1,6 @@
|
||||
;-*-Scheme-*-
|
||||
|
||||
(test-setup 2345.0 #f)
|
||||
(define float-symbol 2345.0)
|
||||
(format #t "~,,0f~%" float-symbol)
|
||||
|
||||
@@ -0,0 +1,15 @@
|
||||
;-*-Scheme-*-
|
||||
|
||||
(test-setup 256 #f)
|
||||
|
||||
(defun pow-test ((base float) (exponent integer))
|
||||
(let ((result base))
|
||||
(while (> exponent 1)
|
||||
(*! result base)
|
||||
(-! exponent 1)
|
||||
)
|
||||
result
|
||||
)
|
||||
)
|
||||
|
||||
(format #t "~,,0f~%" (pow-test 2.0 8))
|
||||
@@ -0,0 +1,6 @@
|
||||
;-*-Scheme-*-
|
||||
|
||||
(test-setup 120.000 #f)
|
||||
|
||||
(format #t "~,,0f~%" (* 1.2 25.0 4.0))
|
||||
|
||||
@@ -0,0 +1,61 @@
|
||||
;-*-Scheme-*-
|
||||
|
||||
|
||||
|
||||
(test-setup 'automatic-pass #f)
|
||||
|
||||
(format #t "test newline~%newline~%")
|
||||
(format #t "test tilde ~~ ~%")
|
||||
|
||||
;; test g, G
|
||||
|
||||
(format #t "test A print boxed-string: ~a~%" "boxed string!")
|
||||
(format #t "test A print symbol: ~A~%" 'a-symbol)
|
||||
(format #t "test A make boxed object longer: ~17A!~%" "srt")
|
||||
(format #t "test A non-default pad: ~12,'za~%" 'pad-me)
|
||||
(format #t "test A shorten(4): ~4a~%" 'a234567)
|
||||
(format #t "test A don'tchange(4): ~4a~%" 'a234)
|
||||
(format #t "test A shorten with pad(4): ~4,'za~%" 'shorten-me)
|
||||
(format #t "test A a few things ~a ~a ~a ~a~%" "one thing" 'a-second integer print)
|
||||
|
||||
|
||||
(format #t "test S ~s ~s ~s~%" "a string" 'a-symbol "another string!")
|
||||
|
||||
(format #t "test C ~c ~c~%" 41 #x5d)
|
||||
|
||||
(format #t "test P (no type) ~p~%" print)
|
||||
(format #t "test P (with type) ~`integer`p~%" print)
|
||||
|
||||
(format #t "test I (no type) ~i" inspect)
|
||||
(format #t "test I (with type) ~`integer`i" inspect)
|
||||
|
||||
(format #t "test X ~x ~10x ~10,'.x ~3x ~3,'.x~%" #xbaadbeef #x2 #x3 #x0badbeef #x0badbeef)
|
||||
|
||||
(format #t "test D ~d ~10d ~10,'.d ~3d ~3,'.d~%" #xbaadbeef #x2 #x3 #x0badbeef #x0badbeef)
|
||||
|
||||
(format #t "test B ~b ~10b ~10,'.b ~3b ~3,'.b~%" #xbaadbeef #x2 #x3 #x0badbeef #x0badbeef)
|
||||
|
||||
;; test f, F, r, R, m, M
|
||||
|
||||
(format #t "test E ~E ~e ~e~%" 1 20 301)
|
||||
(format #t "test pass through ~10,'b,2W~%")
|
||||
|
||||
(format #t "test tab~Taftertab~%")
|
||||
(format #t "test many ~d ~d ~d ~d ~d~%" 1 2 3 4 5)
|
||||
|
||||
|
||||
;; test floats
|
||||
(format #t "test f ~F ~12,'0,2f ~f~%" -1.234 1.234 -1.234)
|
||||
(format #t "test r ~R ~12,'0,2r ~r~%" 1.234 1.567 1.987)
|
||||
(format #t "test m ~M ~12,'0,2m ~m~%" 1.234 1.567 1.987)
|
||||
(format #t "test as float ~`float`P~%" -99987623.23123)
|
||||
(format #t "test pi! ~f~%" M_PI)
|
||||
|
||||
;; print the stack pointer?
|
||||
(rlet ((sp :reg rsp :type integer)
|
||||
(off :reg r14 :type integer)
|
||||
(st :reg r15 :type integer))
|
||||
(format #t "stack pointer is #x~x~%" sp)
|
||||
(format #t "offset pointer is #x~x~%" off)
|
||||
(format #t "st pointer is #x~x~%" st)
|
||||
)
|
||||
@@ -0,0 +1,11 @@
|
||||
;-*-Scheme-*-
|
||||
|
||||
|
||||
(test-setup 23 #f)
|
||||
|
||||
(defun return-second-arg (one two three)
|
||||
two)
|
||||
|
||||
(return-second-arg 1 23 4)
|
||||
|
||||
|
||||
@@ -0,0 +1,9 @@
|
||||
;-*-Scheme-*-
|
||||
|
||||
(test-setup 31415.0 #f)
|
||||
|
||||
(defun return-const-float ()
|
||||
31415.0
|
||||
)
|
||||
(format #t "~,,0f~%" (return-const-float))
|
||||
|
||||
@@ -0,0 +1,12 @@
|
||||
;-*-Scheme-*-
|
||||
|
||||
|
||||
(test-setup 3 #f)
|
||||
|
||||
(block my-block
|
||||
1
|
||||
(goto skip-early-return)
|
||||
(return-from my-block 2)
|
||||
(label skip-early-return)
|
||||
3
|
||||
)
|
||||
@@ -0,0 +1,11 @@
|
||||
;-*-Scheme-*-
|
||||
|
||||
|
||||
(test-setup 16 #f)
|
||||
|
||||
(let* ((base (the integer integer))
|
||||
(field (the integer (-> integer methods)))
|
||||
(offset (- field base)))
|
||||
;;(format #t "offset of methods table is ~d~%" offset)
|
||||
offset
|
||||
)
|
||||
@@ -0,0 +1,14 @@
|
||||
;-*-Scheme-*-
|
||||
|
||||
|
||||
(test-setup 44 #f)
|
||||
|
||||
;; test calling an inline function. doesn't actually verify the call is inline.
|
||||
|
||||
(defun inline-test-function-2 ((x integer))
|
||||
;; inline this function by default.
|
||||
(declare (allow-inline))
|
||||
(* 4 x)
|
||||
)
|
||||
|
||||
(+ (inline-test-function-2 8) ((inline inline-test-function-2) 3))
|
||||
@@ -0,0 +1,8 @@
|
||||
(test-setup '((c . w) (a . b) (e . f)) #f)
|
||||
|
||||
(let ((alist (list (cons 'a 'b)
|
||||
(cons 'c 'd)
|
||||
(cons 'e 'f))))
|
||||
(set! alist (insert-cons! (cons 'c 'w) alist))
|
||||
(format #t "~A~%" alist)
|
||||
)
|
||||
@@ -0,0 +1,6 @@
|
||||
;-*-Scheme-*-
|
||||
|
||||
(test-setup 'd #f)
|
||||
(format #t "~A~%"
|
||||
(car (last (list 'a 'b 'c 'd)))
|
||||
)
|
||||
@@ -0,0 +1,10 @@
|
||||
;-*-Scheme-*-
|
||||
|
||||
(test-setup 30 #f)
|
||||
(define *test-result*
|
||||
(let ((x 1)
|
||||
(y (test-function 1 2 3 4))
|
||||
(z 3))
|
||||
y)
|
||||
)
|
||||
(test-result *test-result*)
|
||||
@@ -0,0 +1,15 @@
|
||||
;-*-Scheme-*-
|
||||
|
||||
(test-setup 30 #f)
|
||||
(define *test-result*
|
||||
(let* ((x 1)
|
||||
(y 2)
|
||||
(z 3)
|
||||
(a 4)
|
||||
(b (test-function x y z a))
|
||||
(d 5)
|
||||
)
|
||||
b
|
||||
)
|
||||
)
|
||||
(test-result *test-result*)
|
||||
@@ -0,0 +1,7 @@
|
||||
;-*-Scheme-*-
|
||||
|
||||
|
||||
(test-setup '(a b c d) #f)
|
||||
|
||||
(print (list 'a 'b 'c 'd))
|
||||
(format #t "~%")
|
||||
@@ -0,0 +1,5 @@
|
||||
;-*-Scheme-*-
|
||||
|
||||
(test-setup 'automatic-pass #f)
|
||||
|
||||
(:gl)
|
||||
@@ -0,0 +1,4 @@
|
||||
(test-setup '(c d) #f)
|
||||
|
||||
(format #t "~A~%"
|
||||
(member 'c (list 'a 'b 'c 'd)))
|
||||
@@ -0,0 +1,5 @@
|
||||
(test-setup #f #f)
|
||||
|
||||
(format #t "~A~%"
|
||||
(member 1234 (list 'a 'b 'c 'd))
|
||||
)
|
||||
@@ -0,0 +1,18 @@
|
||||
;-*-Scheme-*-
|
||||
|
||||
;; add two constants together.
|
||||
(test-setup 13 #f)
|
||||
|
||||
(let* ((base-addr #x6000000)
|
||||
(offset #x123)
|
||||
(ptr-int32 (the (pointer int32) base-addr))
|
||||
(ptr-int16 (the (pointer int16) #x6000123))
|
||||
)
|
||||
(set! (-> ptr-int32 1) #x00070006)
|
||||
(mem-copy! ptr-int16 ptr-int32 8)
|
||||
(+ (-> ptr-int16 2)
|
||||
(-> ptr-int16 3)
|
||||
)
|
||||
)
|
||||
|
||||
|
||||
@@ -0,0 +1,25 @@
|
||||
;-*-Scheme-*-
|
||||
|
||||
;; add two constants together.
|
||||
(test-setup #x0b #f)
|
||||
|
||||
(let* ((base-addr #x6000000)
|
||||
(word-cnt 23)
|
||||
(base (the (pointer int32) base-addr))
|
||||
(foo (mem-set32! base #x0 (+ 1 word-cnt)))
|
||||
(last-byte (the (pointer uint8) (+ base-addr 3 (* 4 (- word-cnt 1)))))
|
||||
(dst (mem-set32! base #x0badbeef word-cnt))
|
||||
)
|
||||
|
||||
(if (!= dst base)
|
||||
(format #t "test failed, bad base returned!~%")
|
||||
)
|
||||
|
||||
(if (!= 0 (-> last-byte 1))
|
||||
(format #t "set too many bytes!~%")
|
||||
)
|
||||
|
||||
(-> last-byte 0)
|
||||
)
|
||||
|
||||
|
||||
@@ -0,0 +1,8 @@
|
||||
|
||||
(test-setup 12 #f)
|
||||
|
||||
(expect-true (eq? (-> process methods 3) (method process inspect)))
|
||||
|
||||
(expect-true (eq? (-> string methods 3) (method "test" inspect)))
|
||||
|
||||
12
|
||||
@@ -0,0 +1,6 @@
|
||||
;-*-Scheme-*-
|
||||
|
||||
|
||||
(test-setup 10 #f)
|
||||
|
||||
(+ (min 1 2) (min 2 -4) (max 10 2) (max 3 1))
|
||||
@@ -0,0 +1,11 @@
|
||||
;-*-Scheme-*-
|
||||
|
||||
(test-setup 10 #f)
|
||||
|
||||
(defglobalconstant c1 3)
|
||||
|
||||
(+ c1 (mlet ((c1 4))
|
||||
c1
|
||||
)
|
||||
c1
|
||||
)
|
||||
@@ -0,0 +1,14 @@
|
||||
;-*-Scheme-*-
|
||||
|
||||
(test-setup 7 #f)
|
||||
|
||||
;; this computes nothing that we can check, but verifies that the coloring
|
||||
;; doesn't do something crazy when constrained a little strangely
|
||||
(rlet ((x :reg rsp :type int64))
|
||||
(mod x 2)
|
||||
(mod 2 x)
|
||||
)
|
||||
|
||||
(let ((x 33))
|
||||
(+ (mod x 10) 4)
|
||||
)
|
||||
@@ -0,0 +1,11 @@
|
||||
;-*-Scheme-*-
|
||||
|
||||
(test-setup -12 #f)
|
||||
|
||||
(defun product ((a integer) (b integer))
|
||||
(* b a)
|
||||
)
|
||||
|
||||
(product 4 -3)
|
||||
|
||||
|
||||
@@ -0,0 +1,7 @@
|
||||
;-*-Scheme-*-
|
||||
|
||||
|
||||
(test-setup -123 #f)
|
||||
|
||||
(define a-negative-symbol -123)
|
||||
a-negative-symbol
|
||||
@@ -0,0 +1,22 @@
|
||||
;-*-Scheme-*-
|
||||
|
||||
|
||||
(test-setup 7 #f)
|
||||
|
||||
(block outer-block
|
||||
1
|
||||
2
|
||||
(block inner-block
|
||||
3
|
||||
4
|
||||
(return-from inner-block 7)
|
||||
5
|
||||
6
|
||||
)
|
||||
)
|
||||
|
||||
;; with v1. const prop and fancy coloring:
|
||||
; 0: b8 07 00 00 00 mov eax,0x7
|
||||
; 5: e9 05 00 00 00 jmp 0xf
|
||||
; a: b8 06 00 00 00 mov eax,0x6
|
||||
; f: c3 ret
|
||||
@@ -0,0 +1,16 @@
|
||||
;-*-Scheme-*-
|
||||
|
||||
|
||||
(test-setup 8 #f)
|
||||
|
||||
(block outer-block
|
||||
1
|
||||
2
|
||||
(block inner-block
|
||||
3
|
||||
4
|
||||
(return-from inner-block 7)
|
||||
5
|
||||
)
|
||||
8
|
||||
)
|
||||
@@ -0,0 +1,16 @@
|
||||
;-*-Scheme-*-
|
||||
|
||||
|
||||
(test-setup 7 #f)
|
||||
|
||||
(block outer-block
|
||||
1
|
||||
2
|
||||
(block inner-block
|
||||
3
|
||||
4
|
||||
(return-from outer-block 7)
|
||||
5
|
||||
)
|
||||
8
|
||||
)
|
||||
@@ -0,0 +1,13 @@
|
||||
;-*-Scheme-*-
|
||||
|
||||
|
||||
(test-setup 'efgh #f)
|
||||
|
||||
(let ((my-pair (cons (cons 'a 'b) (cons 'c 'd))))
|
||||
(set! (car (car my-pair)) 'e)
|
||||
(set! (car (cdr my-pair)) 'f)
|
||||
(set! (cdr (car my-pair)) 'g)
|
||||
(set! (cdr (cdr my-pair)) 'h)
|
||||
(format #t "~A~A~A~A~%" (car (car my-pair)) (car (cdr my-pair)) (cdr (car my-pair)) (cdr (cdr my-pair)))
|
||||
(format #t "~A~%" my-pair)
|
||||
)
|
||||
@@ -0,0 +1,23 @@
|
||||
;-*-Scheme-*-
|
||||
|
||||
|
||||
(test-setup 10 #f)
|
||||
|
||||
;; by putting some more functions, we make sure that branches in functions
|
||||
;; in later functions actually are using the right stuff
|
||||
(defun first-function ((a integer))
|
||||
(+ a 2)
|
||||
(+ a 3)
|
||||
(+ a 4)
|
||||
(+ a 6)
|
||||
(+ a 10)
|
||||
)
|
||||
|
||||
(defun second-function ((b integer))
|
||||
(if (> 2 b)
|
||||
0
|
||||
10
|
||||
)
|
||||
)
|
||||
|
||||
(second-function (second-function (second-function 3)))
|
||||
@@ -0,0 +1,14 @@
|
||||
;-*-Scheme-*-
|
||||
|
||||
;; this is mostly to test that the coloring works.
|
||||
(test-setup 2 #f)
|
||||
|
||||
(defun r2 (one two three)
|
||||
two)
|
||||
|
||||
(defun r1 (one two three)
|
||||
one)
|
||||
|
||||
|
||||
(r2 1 (r1 2 3 4) 5)
|
||||
|
||||
@@ -0,0 +1,20 @@
|
||||
(test-setup 2820 #f)
|
||||
|
||||
(deftype my-inline-array-type (inline-array-class)
|
||||
()
|
||||
)
|
||||
|
||||
(set! (-> my-inline-array-type heap-base) 12)
|
||||
|
||||
(let ((my-inline-array-obj
|
||||
(the my-inline-array-type
|
||||
((-> my-inline-array-type methods 0)
|
||||
'debug
|
||||
my-inline-array-type
|
||||
234))))
|
||||
;;(-> my-inline-array-obj allocated-length)
|
||||
(asize-of my-inline-array-obj)
|
||||
;;(inspect my-inline-array-type)
|
||||
;;(inspect my-inline-array-obj)
|
||||
;;(print-type my-inline-array-obj)
|
||||
)
|
||||
@@ -0,0 +1,7 @@
|
||||
(test-setup "alligator" #f)
|
||||
|
||||
(let ((new-string (new 'global 'string 17 "alligator")))
|
||||
(expect-true (= 17 (-> new-string allocated-length)))
|
||||
(expect-true (= 9 (length new-string)))
|
||||
(printl new-string)
|
||||
)
|
||||
@@ -0,0 +1,21 @@
|
||||
(test-setup 4 #f)
|
||||
|
||||
(expect-true (= 1.2 1.2))
|
||||
(expect-true (= 1 1))
|
||||
(expect-false (!= 1.2 1.2))
|
||||
(expect-false (= 1 2))
|
||||
(expect-true (= 1 1.2))
|
||||
(expect-false (= 1.2 1))
|
||||
|
||||
(expect-true (> 2 1))
|
||||
(expect-false (< 2 1))
|
||||
|
||||
(expect-true (> 3.2 3))
|
||||
|
||||
(expect-true (= 1 (the integer 1.2)))
|
||||
(expect-true (= (the float 1) (the integer 1.2)))
|
||||
|
||||
(expect-true (= 0.6 (- 1.2 0.6)))
|
||||
(expect-true (= 0.6 (- 1.0 0.2 0.2)))
|
||||
(expect-true (= 0.6 (- -0.6)))
|
||||
4
|
||||
@@ -0,0 +1,30 @@
|
||||
(test-setup 16 #f)
|
||||
|
||||
(deftype small-struct-packed (structure)
|
||||
((v1 int32)
|
||||
(v2 int32)
|
||||
(v3 int32))
|
||||
(:pack)
|
||||
)
|
||||
|
||||
(deftype small-struct (structure)
|
||||
((v1 int32)
|
||||
(v2 int32)
|
||||
(v3 int32))
|
||||
(:no-pack)
|
||||
)
|
||||
|
||||
(deftype test-struct-type (basic)
|
||||
((packed small-struct-packed 10 :inline #t)
|
||||
(not-packed small-struct 10 :inline #t)
|
||||
)
|
||||
)
|
||||
|
||||
(let* ((obj (new 'static 'test-struct-type))
|
||||
(pack-diff (- (the integer (&-> obj packed 1 v1)) (the integer (&-> obj packed 0 v1))))
|
||||
(unpack-diff (- (the integer (&-> obj not-packed 1 v1)) (the integer (&-> obj not-packed 0 v1))))
|
||||
)
|
||||
|
||||
(expect-true (eq? 12 pack-diff))
|
||||
unpack-diff
|
||||
)
|
||||
@@ -0,0 +1,7 @@
|
||||
;-*-Scheme-*-
|
||||
|
||||
(test-setup 8 #f)
|
||||
(let ((lst (list 5 4 3 2 1 0)))
|
||||
(asize-of (the pair lst))
|
||||
)
|
||||
|
||||
@@ -0,0 +1,7 @@
|
||||
;-*-Scheme-*-
|
||||
|
||||
(test-setup 6 #f)
|
||||
(let ((lst (list 5 4 3 2 1 0)))
|
||||
(length (the pair lst))
|
||||
)
|
||||
|
||||
@@ -0,0 +1,11 @@
|
||||
;-*-Scheme-*-
|
||||
|
||||
(test-setup "test pass" #f)
|
||||
|
||||
;; add two numbers in a function
|
||||
|
||||
(expect-true (pair? '()))
|
||||
(expect-false (pair? integer))
|
||||
(print "test pass")
|
||||
(format #t "~%")
|
||||
|
||||
@@ -0,0 +1,16 @@
|
||||
;-*-Scheme-*-
|
||||
|
||||
;; add two constants together.
|
||||
(test-setup 13 #f)
|
||||
|
||||
(let* ((base-addr #x6000000)
|
||||
(ptr-int32 (the (pointer int32) base-addr))
|
||||
(ptr-int16 (the (pointer int16) base-addr))
|
||||
)
|
||||
(set! (-> ptr-int32 1) #x00070006)
|
||||
(+ (-> ptr-int16 2)
|
||||
(-> ptr-int16 3)
|
||||
)
|
||||
)
|
||||
|
||||
|
||||
@@ -0,0 +1,7 @@
|
||||
;-*-Scheme-*-
|
||||
|
||||
;; add two constants together.
|
||||
(test-setup -13 #f)
|
||||
(printl (the binteger -13))
|
||||
|
||||
|
||||
Some files were not shown because too many files have changed in this diff Show More
Reference in New Issue
Block a user