Changeset 39694 in project

Timestamp:

03/13/21 22:10:44 (6 weeks ago)

Author:

Kon Lovett

Message:

remove "primitives", use record-variants, add hof tests, new test runner

Location:

release/5/stack/trunk

Files:

• chicken-primitive-object-inlines.scm (deleted)
• inline-type-checks.scm (deleted)
• stack.egg (modified) (1 diff)
• stack.scm (modified) (7 diffs)
• tests/run-ident.scm (added)
• tests/run.scm (modified) (6 diffs)
• tests/stack-test.scm (modified) (4 diffs)

release/5/stack/trunk/stack.egg

@@ -3 +3 @@
 
 ((synopsis "Provides LIFO queue (stack) operations")
- (version "3.0.4")
+ (version "3.0.5")
  (category data)
- (author "[[kon lovett]]")
+ (author "Kon Lovett")
  (license "BSD")
- (dependencies
-        (check-errors "3.1.0"))
+ (dependencies record-variants check-errors)
  (test-dependencies test)
  (components

release/5/stack/trunk/stack.scm

@@ -1 @@
-;;;; stack.scm
+;;;; stack.scm -*- Scheme -*-
 ;;;; Kon Lovett, May '17
 ;;;; Kon Lovett, Mar '09
@@ -8 +8 @@
 ;; Issues
 ;;
-;; - All operations inlined & primitive due to high-performance nature.
 
 (declare
@@ -29 +28 @@
   stack-cut!
   stack-pop!
+  stack-fold
   stack-map
   stack-for-each
   stack-literal-form)
 
-(import scheme)
-(import (srfi 10))
-(import (chicken base))
-(import (chicken fixnum))
-(import (chicken type))
-(import (only (chicken port) with-output-to-port))
-(import (only (chicken format) format))
-(import (only type-errors define-error-type error-list error-fixnum))
-
-(include "chicken-primitive-object-inlines")
-(include "inline-type-checks")
+(import scheme
+  (srfi 10)
+  (chicken base)
+  (chicken fixnum)
+  (chicken type)
+  (only (chicken port) with-output-to-port)
+  (only (chicken format) format)
+  (only record-variants define-record-type-variant)
+  (only type-checks define-check+error-type check-list check-fixnum))
 
 #| chicken
+flip
+foldl
+foldr
 warning
 :
@@ -60 +61 @@
 |#
 
+(define-inline (%list-pair-ref ls0 i0)
+  ;(assert (and (proper-list? ls0) (exact? i0) (<= 0 i0 (sub1 (length ls0)))))
+  (let loop ((ls ls0) (i i0))
+    (cond
+      ((null? ls) '() )
+      ((fx= 0 i)  ls )
+      (else       (loop (cdr ls) (fx- i 1)) ) ) ) )
+
+(define-inline (%list-copy ls) (foldr cons '() ls))
+
+(define-inline (%list-fold f init ls) (foldl (flip f) init ls))
+
+(define-inline (%fxclosed-left? l x h) (and (fx<= l x) (fx< x h)))
+
 ;; Stack Type
 
-(define-type stack (struct stack#stack))
-
-(define-constant stack 'stack#stack)
-
-(define stack)
+;(define-type stack (struct stack#stack))
+(define-type stack (struct stack))
+
+(: make-stack (-> stack))
+(: list->stack (list -> stack))
+(: stack? (* -> boolean))
+(: stack-empty? (stack -> boolean))
+(: stack-count (stack -> fixnum))
+(: stack-peek (stack #!optional fixnum -> *))
+(: stack-empty! (stack -> void))
+(: stack-poke! (stack * #!optional fixnum -> void))
+(: stack-push! (stack #!rest * -> void))
+(: stack-cut! (stack fixnum #!optional fixnum -> list))
+(: stack-pop! (stack -> *))
+(: stack->list (stack -> list))
+(: stack-fold (stack procedure * -> *))
+(: stack-map (stack procedure -> list))
+(: stack-for-each (stack procedure -> void))
+
+;; Stack Object
+
+(define stack 'stack)
+(define-record-type-variant stack (unchecked inline unsafe)
+  (%make-stack lst cnt)
+  (%stack?)
+  (lst %stack-list %stack-list-set!)
+  (cnt %stack-count %stack-count-set!))
+
+;NOTE ref's forward defined `stack?'
+(define-check+error-type stack)
+
+(define (error-corrupted-stack loc obj)         (##sys#signal-hook #:runtime-error loc "stack corrupted" obj))
+(define (error-stack-underflow loc stk)         (##sys#signal-hook #:limit-error loc "stack underflow" stk))
+(define (error-outside-range loc obj low high)  (##sys#signal-hook #:bounds-error loc "out of range" obj low high))
+
+(define-inline (%make-empty-stack) (%make-stack '() 0))
 
 ;; Stack List
 
-(define-inline (%stack-list stk)          (%structure-ref stk 1))
-(define-inline (%stack-list-empty? stk)   (%null? (%stack-list stk)))
-(define-inline (%stack-list-set! stk ls)  (%structure-set! stk 1 ls))
-(define-inline (%stack-list-empty! stk)   (%structure-set!/immediate stk 1 '()))
+(define-inline (%stack-list-empty? stk)   (null? (%stack-list stk)))
+(define-inline (%stack-list-empty! stk)   (%stack-list-set! stk '()))
 
 ;; Stack Count
 
-(define-inline (%stack-count stk)           (%structure-ref stk 2))
-(define-inline (%stack-count-set! stk cnt)  (%structure-set!/immediate stk 2 cnt))
-(define-inline (%stack-count-inc! stk cnt)  (%stack-count-set! stk (%fx+ (%stack-count stk) cnt)))
-(define-inline (%stack-count-dec! stk cnt)  (%stack-count-set! stk (%fx- (%stack-count stk) cnt)))
+(define-inline (%stack-count-inc! stk cnt)  (%stack-count-set! stk (fx+ (%stack-count stk) cnt)))
+(define-inline (%stack-count-dec! stk cnt)  (%stack-count-set! stk (fx- (%stack-count stk) cnt)))
 
 ;; Stack Object
 
-(define-inline (%make-stack) (%make-structure stack '() 0))
-
-(define-inline (%stack? obj) (%structure-instance? obj stack))
-
+#; ;UNUSED
 (define-inline (%valid-as-stack? obj)
   (and
-    (%fx= 3 (%structure-length obj))
-    (%list? (%stack-list obj)) ) )
+    (fx= 3 (%structure-length obj))
+    (list? (%stack-list obj))
+    (fixnum? (%stack-count obj)) ) )
 
 ;; Stack Operations
@@ -104 +144 @@
   (%stack-count-dec! stk 1)
         (let ((ls (%stack-list stk)))
-                (%stack-list-set! stk (%cdr ls))
-                (%car ls) ) )
+                (%stack-list-set! stk (cdr ls))
+                (car ls) ) )
 
 (define-inline (%stack-push/1! stk obj)
   (%stack-count-inc! stk 1)
-        (%stack-list-set! stk (%cons obj (%stack-list stk))) )
+        (%stack-list-set! stk (cons obj (%stack-list stk))) )
 
 (define-inline (%stack-push! stk ls)
-  (if (%null? (%cdr ls))
-    (%stack-push/1! stk (%car ls))
-    (%list-for-each/1 (lambda (x) (%stack-push/1! stk x)) ls) ) )
+  (if (null? (cdr ls))
+    (%stack-push/1! stk (car ls))
+    (for-each (lambda (x) (%stack-push/1! stk x)) ls) ) )
 
 (define-inline (%stack-node-ref loc stk idx)
   (let ((pr (%list-pair-ref (%stack-list stk) idx)))
-                (if (%pair? pr)
+                (if (pair? pr)
                   pr
       (error-outside-range loc idx 0 (%stack-count stk)) ) ) )
@@ -124 +164 @@
 ;; Helpers
 
-(define-inline (%check-stack loc obj)
-  (unless (%stack? obj) (error-stack loc obj))
-  (unless (%valid-as-stack? obj) (error-corrupted-stack loc obj))
-  obj )
-
-(define-inline (%check-stack-underflow loc stk)
+(define (check-stack-underflow loc stk)
   (when (%stack-empty? stk) (error-stack-underflow loc stk))
   stk )
 
-(define-inline (%check-fixnum-index loc lfx fx hfx)
+(define (check-fixnum-index loc lfx fx hfx)
   (unless (%fxclosed-left? lfx fx hfx) (error-outside-range loc fx lfx hfx))
   ;cannot return useful value (singular)
@@ -140 +175 @@
 ;;;
 
-(define-error-type stack)
-
-(define (error-corrupted-stack loc obj)         (##sys#signal-hook #:runtime-error loc "stack corrupted" obj))
-(define (error-stack-underflow loc stk)         (##sys#signal-hook #:limit-error loc "stack underflow" stk))
-(define (error-outside-range loc obj low high)  (##sys#signal-hook #:bounds-error loc "out of range" obj low high))
-
-;;;
-
-(: make-stack (-> stack))
-;
-(define (make-stack) (%make-stack))
-
-(: list->stack (list -> stack))
-;
+(define (make-stack) (%make-empty-stack))
+
 (define (list->stack ls)
-  (%check-list 'list->stack ls)
-        (let ((stk (%make-stack)))
-    (%stack-count-set! stk (%length ls))
+  (check-list 'list->stack ls)
+        (let ((stk (%make-empty-stack)))
+    (%stack-count-set! stk (length ls))
     (%stack-list-set! stk (%list-copy ls))
     stk ) )
 
-(: stack? (* -> boolean))
-;
 (define (stack? obj) (%stack? obj))
 
-(: stack-empty? (stack -> boolean))
-;
-(define (stack-empty? stk) (%stack-empty? (%check-stack 'stack-empty? stk)))
-
-(: stack-count (stack -> fixnum))
-;
-(define (stack-count stk) (%stack-count (%check-stack 'stack-count stk)))
-
-(: stack-peek (stack #!optional fixnum -> *))
-;
-(define (stack-peek stk #!optional (idx 0)) (%car (%stack-node-ref 'stack-peek (%check-stack 'stack-peek stk) idx)))
-
-(: stack-empty! (stack -> void))
-;
-(define (stack-empty! stk) (%stack-empty! (%check-stack 'stack-empty! stk)))
-
-(: stack-poke! (stack * #!optional fixnum -> void))
-;
-(define (stack-poke! stk obj #!optional (idx 0)) (%set-car!/mutate (%stack-node-ref 'stack-poke! (%check-stack 'stack-poke! stk) idx) obj))
-
-(: stack-push! (stack #!rest * -> void))
-;
-(define (stack-push! stk #!rest ls) (unless (%null? ls) (%stack-push! (%check-stack 'stack-push! stk) ls)))
-
-(: stack-cut! (stack fixnum #!optional fixnum -> list))
-;
+(define (stack-empty? stk) (%stack-empty? (check-stack 'stack-empty? stk)))
+
+(define (stack-count stk) (%stack-count (check-stack 'stack-count stk)))
+
+(define (stack-peek stk #!optional (idx 0)) (car (%stack-node-ref 'stack-peek (check-stack 'stack-peek stk) idx)))
+
+(define (stack-empty! stk) (%stack-empty! (check-stack 'stack-empty! stk)))
+
+(define (stack-poke! stk obj #!optional (idx 0)) (set-car! (%stack-node-ref 'stack-poke! (check-stack 'stack-poke! stk) idx) obj))
+
+(define (stack-push! stk #!rest ls) (unless (null? ls) (%stack-push! (check-stack 'stack-push! stk) ls)))
+
 (define (stack-cut! stk start #!optional (end (%stack-count stk)))
-  (%check-stack 'stack-cut! stk)
-  (%check-fixnum 'stack-cut! start)
-  (%check-fixnum 'stack-cut! end)
-  (%check-fixnum-index 'stack-cut! 0 start end)
-  (%check-fixnum-index 'stack-cut! start end (%fx+ (%stack-count stk) 1))
-  (let ((cnt (%fx- end start)))
+  (check-stack 'stack-cut! stk)
+  (check-fixnum 'stack-cut! start)
+  (check-fixnum 'stack-cut! end)
+  (check-fixnum-index 'stack-cut! 0 start end)
+  (check-fixnum-index 'stack-cut! start end (fx+ (%stack-count stk) 1))
+  (let ((cnt (fx- end start)))
     (%stack-count-dec! stk cnt)
     ; From the top?
-    (if (%fx= 0 start)
+    (if (fx= 0 start)
       ;then removing leading elements
       (let* (
         (spr (%stack-list stk))
-        (epr (%list-pair-ref spr (%fx- cnt 1)))
+        (epr (%list-pair-ref spr (fx- cnt 1)))
         (ls spr) )
-        (%stack-list-set! stk (%cdr epr))
-        (%set-cdr!/immediate epr '())
+        (%stack-list-set! stk (cdr epr))
+        (set-cdr! epr '())
         ls )
       ;else removing interior elements
       (let* (
-        (spr (%stack-node-ref 'stack-cut! stk (%fx- start 1)))
+        (spr (%stack-node-ref 'stack-cut! stk (fx- start 1)))
         (epr (%list-pair-ref spr cnt))
-        (ls (%cdr spr)) )
-        (%set-cdr!/mutate spr (%cdr epr))
-        (%set-cdr!/immediate epr '())
+        (ls (cdr spr)) )
+        (set-cdr! spr (cdr epr))
+        (set-cdr! epr '())
         ls ) ) ) )
 
-(: stack-pop! (stack -> *))
-;
 (define (stack-pop! stk)
-  (%check-stack 'stack-pop! stk)
-        (%check-stack-underflow 'stack-pop! stk)
+  (check-stack 'stack-pop! stk)
+        (check-stack-underflow 'stack-pop! stk)
         (%stack-pop! stk) )
 
-(: stack->list (stack -> list))
-;
-(define (stack->list stk) (%list-copy (%stack-list (%check-stack 'stack->list stk))))
-
-(: stack-fold (stack procedure * -> *))
-;
-(define (stack-fold stk func init) (%list-fold/1 func init (%stack-list (%check-stack 'stack-fold stk))))
-
-(: stack-map (stack procedure -> list))
-;
-(define (stack-map stk func) (%list-map/1 func (%stack-list (%check-stack 'stack-map stk))))
-
-(: stack-for-each (stack procedure -> void))
-;
-(define (stack-for-each stk proc) (%list-for-each/1 proc (%stack-list (%check-stack 'stack-for-each stk))))
+(define (stack->list stk) (%list-copy (%stack-list (check-stack 'stack->list stk))))
+
+(define (stack-fold stk func init) (%list-fold func init (%stack-list (check-stack 'stack-fold stk))))
+
+(define (stack-map stk func) (map func (%stack-list (check-stack 'stack-map stk))))
+
+(define (stack-for-each stk proc) (for-each proc (%stack-list (check-stack 'stack-for-each stk))))
 
 ;;; Read/Print Syntax

release/5/stack/trunk/tests/run.scm

@@ -3 +3 @@
 (import scheme)
 
-;;; Create Egg Const
+;; Create Egg Const
 
-(define EGG-NAME "stack")
+(include-relative "run-ident")
 
 ;chicken-install invokes as "<csi> -s run.scm <eggnam> <eggdir>"
@@ -18 +18 @@
 
 (define *args* (argv))
+(define *current-directory* (cond-expand (unix "./") (else #f)))
+;no -disable-interrupts or -no-lambda-info
+(define *csc-init-options* '(-inline-global -local -inline -specialize
+  -optimize-leaf-routines -clustering -lfa2 -no-trace -unsafe -strict-types))
+(define *test-files-rx* (irregex '(: (+ graph) #\- "test" #\. "scm")))
 
-(define (egg-name args #!optional (def EGG-NAME))
+(define (remq obj ls)
+  (let loop ((curr ls) (prev '()))
+    (cond
+      ((null? curr)
+        ls )
+      ((eq? obj (car curr))
+        (if (null? prev)
+          (cdr ls)
+          (begin
+            (set-cdr! prev (cdr curr))
+            ls ) ) )
+      (else
+        (loop (cdr curr) curr) ) ) ) )
+
+(define (remqs os ls)
+  (let loop ((ls ls) (os os))
+    (cond
+      ((null? os)
+        ls )
+      (else
+        (loop (remq (car os) ls) (cdr os)) ) ) ) )
+
+(define (egg-name #!optional (args *args*) (def EGG-NAME))
   (cond
     ((<= 4 (length *args*)) (cadddr *args*) )
@@ -26 +53 @@
       (error 'run "cannot determine egg-name") ) ) )
 
-(define *current-directory* (cond-expand (unix "./") (else #f)))
-(define *egg* (egg-name *args*))
+(define (as-csc-options ls)
+  (apply string-append (intersperse (map symbol->string ls) " ")) )
 
-;no -disable-interrupts or -no-lambda-info
-(define *csc-options* "-inline-global -local -inline \
-  -specialize -optimize-leaf-routines -clustering -lfa2 \
-  -no-trace -unsafe \
-  -strict-types")
+(define (csc-options)
+  (as-csc-options (remqs *csc-remv-options* *csc-init-options*)) )
 
-(define *test-files-rx* (irregex '(: (+ graph) #\- "test" #\. "scm")))
 (define (test-filename name) (string-append name "-test"))
+
 (define (test-files) (find-files "." #:test *test-files-rx* #:limit 1))
 
@@ -43 +67 @@
     name
     (make-pathname *current-directory* (test-filename name) "scm") ) )
+
+;;
 
 (define (run-test-evaluated source)
@@ -54 +80 @@
   (system (pathname-replace-directory (pathname-strip-extension source) *current-directory*)) )
 
-;;;
-
-(define (run-test #!optional (name *egg*) (csc-options *csc-options*))
+(define (run-test #!optional (name (egg-name)) (csc-options (csc-options)))
   (let (
     (source (ensure-test-source-name name)) )
@@ -65 +89 @@
     (run-test-compiled source csc-options) ) )
 
-(define (run-tests #!optional (tests (test-files)) (csc-options *csc-options*))
+(define (run-tests #!optional (tests (test-files)) (csc-options (csc-options)))
   (for-each (cut run-test <> csc-options) tests) )
 
-;;; Do Test
+;; Do Test
 
 (run-tests)

release/5/stack/trunk/tests/stack-test.scm

@@ -18 +18 @@
 
 (test-group "Push!/Pop!/Peek/Poke!"
-  (let ([stk (make-stack)])
+  (let ((stk (make-stack)))
     (stack-push! stk 1)
     (stack-push! stk 2 3)
@@ -36 +36 @@
 
 (test-group "Cut!"
-  (let ([stk (make-stack)])
+  (let ((stk (make-stack)))
     ;3 2 1
     (stack-push! stk 1 2 3)
@@ -55 +55 @@
 
 (test-group "Stack from List"
-  (let ([stk (make-stack)]
-        [stk1 (list->stack '(1 2 3))])
+  (let ((stk (make-stack))
+        (stk1 (list->stack '(1 2 3))))
     ;
     (stack-push! stk 1 2 3)
@@ -66 +66 @@
 )
 
+(test-group "Stack HOF"
+  (let ((stk (list->stack '(1 2 3))))
+    (test 6 (stack-fold stk + 0))
+    (test '(2 3 4) (stack-map stk add1)) )
+)
+
 ;;;