cco/cl-scopes
3
0
Fork 0
Code Issues 1 Pull requests Releases Wiki Activity Actions

replace tabs with spaces

Browse source
This commit is contained in:
Helmut Merz 2024-05-06 12:15:33 +02:00
parent 82038d9dd5
commit 5d7a4c0b82
8 changed files with 54 additions and 54 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

44
forge/forge.lisp
View file

@ -12,26 +12,26 @@
(defclass forge-env ()
((data-stack :initform nil
:reader data-stack
:accessor data-stack!)
:reader data-stack
:accessor data-stack!)
(vocabulary :initform (list *builtins*)
:accessor vocabulary)))
:accessor vocabulary)))
(defun forge-env ()
(let ((fe (make-instance 'forge-env)))
(push (make-hash-table :test 'equalp) (vocabulary fe))
fe))
(push (make-hash-table :test 'equalp) (vocabulary fe))
fe))
(defun exec-str (fe s)
(exec fe (read-from-string
(concatenate 'string "(" s ")"))))
(concatenate 'string "(" s ")"))))
(defun exec (fe code)
(dolist (x code)
(typecase x
(symbol (funcall (comp1 fe x) fe))
(compiled-function (funcall x fe))
(t (pushd fe x)))))
(typecase x
(symbol (funcall (comp1 fe x) fe))
(compiled-function (funcall x fe))
(t (pushd fe x)))))
(defun repl (fe)
(do ((input (read-line) (read-line))) ((string= input "q") nil)
@ -40,20 +40,20 @@
(defun find-word (fe key)
(let ((k (string-downcase (symbol-name key))))
(dolist (voc (vocabulary fe))
(let ((v (gethash k voc)))
(if v (return v))))))
(let ((v (gethash k voc)))
(if v (return v))))))
(defun comp (fe inp)
(let ((code nil))
(dolist (item inp)
(setf code (cons (comp1 fe item) code)))
(reverse code)))
(setf code (cons (comp1 fe item) code)))
(reverse code)))
(defun comp1 (fe item)
(typecase item
(symbol (find-word fe item))
(cons (comp fe item))
(t item)))
(symbol (find-word fe item))
(cons (comp fe item))
(t item)))
(defun register (voc key fn)
(let ((k (if (symbolp key) (symbol-name key) key)))
@ -73,19 +73,19 @@
(reg-b "def" #'(lambda (fe)
(let* ((name (popd fe))
(code (comp fe (popd fe))))
(code (comp fe (popd fe))))
(register (voc fe) name #'(lambda (fe) (exec fe code))))))
(reg-b "const" #'(lambda (fe)
(let ((name (popd fe))
(value (popd fe)))
(value (popd fe)))
(register (voc fe) name #'(lambda (fe) (pushd fe value))))))
(reg-b "var" #'(lambda (fe)
(let ((name (popd fe))
(var (list (popd fe))))
(var (list (popd fe))))
(register (voc fe) name #'(lambda (fe)
(pushd fe #'(lambda (fn)
(pushd fe #'(lambda (fn)
(funcall fn var))))))))
(reg-b "get" #'(lambda (fe)
@ -93,7 +93,7 @@
(reg-b "put" #'(lambda (fe)
(let ((fn (popd fe))
(vl (popd fe)))
(vl (popd fe)))
(funcall fn #'(lambda (x) (setf (car x) vl))))))
; internal definitions

10
scopes.asd
View file

@ -8,11 +8,11 @@
:description ""
:depends-on (:str :sxql)
:components ((:file "forge/forge")
(:file "storage/storage")
(:file "storage/tracking" :depends-on ("storage/storage"))
(:file "testing")
(:file "test/test-forge" :depends-on ("testing" "forge/forge"))
(:file "test/test-storage" :depends-on ("testing" "storage/storage" "storage/tracking")))
(:file "storage/storage")
(:file "storage/tracking" :depends-on ("storage/storage"))
(:file "testing")
(:file "test/test-forge" :depends-on ("testing" "forge/forge"))
(:file "test/test-storage" :depends-on ("testing" "storage/storage" "storage/tracking")))
:long-description "scopes: generic data processing facilities")
;;#.(uiop:read-file-string
;; (uiop:subpathname *load-pathname* "README.md")))

16
scratch.lisp
View file

@ -13,25 +13,25 @@
(defun make-iter ()
(let ((pointers (vector nil nil nil)))
#'(lambda (fn)
(funcall fn pointers))))
#'(lambda (fn)
(funcall fn pointers))))
(defun iter-current (it)
(funcall it #'(lambda (p) (car (svref p 0)))))
(defun classes ()
(let ((r nil))
(maphash #'(lambda (k v)
(maphash #'(lambda (k v)
(setf r (cons k r))) si:*class-name-hash-table*)
(sort r #'(lambda (x y)
(sort r #'(lambda (x y)
(string<= (package-name (symbol-package x))
(package-name (symbol-package y)))))))
(package-name (symbol-package y)))))))
(defun x-make-var (value)
#'(lambda (nv)
(if (null nv)
value
(setf value nv))))
(if (null nv)
value
(setf value nv))))
(defun x-get-var (vf)
(funcall vf nil))

6
storage/storage.lisp
View file

@ -5,8 +5,8 @@
(defpackage :scopes/storage
(:use :common-lisp)
(:export #:*db-params*
#:storage
#:drop-table))
#:storage
#:drop-table))
(in-package :scopes/storage)
@ -20,4 +20,4 @@
(defun drop-table (st tn)
st
(print (sxql:yield
(sxql:drop-table tn :if-exists t))))
(sxql:drop-table tn :if-exists t))))

10
storage/tracking.lisp
View file

@ -5,8 +5,8 @@
(defpackage :scopes/storage/tracking
(:use :common-lisp)
(:export #:track #:time-stamp #:data
#:container
#:create-table))
#:container
#:create-table))
(in-package :scopes/storage/tracking)
@ -22,11 +22,11 @@
(defun create-table (storage table-name head-fields)
storage
(let
((id-type 'bigserial)
(hf-def (mapcar #'(lambda (x) (list x :type 'text)) head-fields)))
((id-type 'bigserial)
(hf-def (mapcar #'(lambda (x) (list x :type 'text)) head-fields)))
(print (sxql:yield
(sxql:make-statement :create-table table-name
(nconc
(nconc
`((trackid :type ,id-type :primary-key t))
hf-def
'((timestamp :type timestamp)

4
test/test-forge.lisp
View file

@ -5,14 +5,14 @@
(defpackage :scopes/test-forge
(:use :common-lisp)
(:local-nicknames (:scf :scopes/forge)
(:sct :scopes/testing))
(:sct :scopes/testing))
(:export #:run))
(in-package :scopes/test-forge)
(defun run ()
(let ((fe (scf:forge-env))
(tst (sct:test-suite)))
(tst (sct:test-suite)))
(test-exec tst fe)
;(format t "~%data-stack ~a" (data-stack fe))
(test-def tst fe)

14
test/test-storage.lisp
View file

@ -5,8 +5,8 @@
(defpackage :scopes/test-storage
(:use :common-lisp)
(:local-nicknames (:storage :scopes/storage)
(:tracking :scopes/storage/tracking)
(:t :scopes/testing))
(:tracking :scopes/storage/tracking)
(:t :scopes/testing))
(:export #:run #:try))
(in-package :scopes/test-storage)
@ -19,13 +19,13 @@
(defun run ()
(let ((st (make-instance 'storage:storage))
(tst (t:test-suite)))
(tst (t:test-suite)))
(test-track tst st)
(t:result tst)))
(defun test-track (tst st)
(let ((tr (make-instance 'tracking:track)))
(storage:drop-table st :tracks)
(tracking:create-table st :tracks '(trackid username))
;(setf (scs:data tr) nil)
(t:assert-eq tst (tracking:data tr) nil)))
(storage:drop-table st :tracks)
(tracking:create-table st :tracks '(trackid username))
;(setf (scs:data tr) nil)
(t:assert-eq tst (tracking:data tr) nil)))

4
testing.lisp
View file

@ -10,8 +10,8 @@
(defclass test-suite ()
((result :initform nil
:reader result
:accessor result!)))
:reader result
:accessor result!)))
(defun test-suite ()
(make-instance 'test-suite))