mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-07-11 23:17:34 +02:00
factoring (chibi posix) into filesystem, process and time modules.
the time module is garbage, because libc time handling is garbage. the signal handling is still experimental, use at your own risk. still need a host module for user/group and other host information.
This commit is contained in:
Alex Shinn
parent
bfbc9313ed
commit
77f2990f28
14 changed files with 461 additions and 117 deletions
3
Makefile
3
Makefile
|
|
@ -83,7 +83,8 @@ all: chibi-scheme$(EXE) libs
|
|||
COMPILED_LIBS := lib/srfi/27/rand$(SO) lib/srfi/33/bit$(SO) \
|
||||
lib/srfi/69/hash$(SO) lib/srfi/98/env$(SO) \
|
||||
lib/chibi/ast$(SO) lib/chibi/net$(SO) \
|
||||
lib/chibi/posix$(SO) lib/chibi/heap-stats$(SO)
|
||||
lib/chibi/filesystem$(SO) lib/chibi/process$(SO) \
|
||||
lib/chibi/time$(SO) lib/chibi/heap-stats$(SO)
|
||||
|
||||
libs: $(COMPILED_LIBS)
|
||||
|
||||
|
|
|
|||
|
|
@ -696,6 +696,7 @@ enum sexp_context_globals {
|
|||
SEXP_G_OOM_ERROR, /* out of memory exception object */
|
||||
SEXP_G_OOS_ERROR, /* out of stack exception object */
|
||||
SEXP_G_OPTIMIZATIONS,
|
||||
SEXP_G_SIGNAL_HANDLERS,
|
||||
SEXP_G_CONFIG_ENV,
|
||||
SEXP_G_MODULE_PATH,
|
||||
SEXP_G_QUOTE_SYMBOL,
|
||||
|
|
|
|||
22
lib/chibi/filesystem.module
Normal file
22
lib/chibi/filesystem.module
Normal file
|
|
@ -0,0 +1,22 @@
|
|||
|
||||
(define-module (chibi filesystem)
|
||||
(export open-input-file-descriptor open-output-file-descriptor
|
||||
duplicate-file-descriptor duplicate-file-descriptor-to
|
||||
close-file-descriptor renumber-file-descriptor
|
||||
delete-file link-file symbolic-link-file rename-file
|
||||
directory-files create-directory delete-directory
|
||||
file-status
|
||||
file-device file-inode
|
||||
file-mode file-num-links
|
||||
file-owner file-group
|
||||
file-represented-device file-size
|
||||
file-block-size file-num-blocks
|
||||
file-access-time file-modification-time file-change-time
|
||||
file-regular? file-directory? file-character?
|
||||
file-block? file-fifo? file-link?
|
||||
file-socket?
|
||||
)
|
||||
(import-immutable (scheme))
|
||||
(include-shared "filesystem")
|
||||
(include "filesystem.scm"))
|
||||
|
||||
39
lib/chibi/filesystem.scm
Normal file
39
lib/chibi/filesystem.scm
Normal file
|
|
@ -0,0 +1,39 @@
|
|||
|
||||
(define (directory-fold dir kons knil)
|
||||
(let ((dir (opendir dir)))
|
||||
(let lp ((res knil))
|
||||
(let ((file (readdir dir)))
|
||||
(if file (lp (kons (dirent-name file) res)) res)))))
|
||||
|
||||
(define (directory-files dir)
|
||||
(directory-fold dir cons '()))
|
||||
|
||||
(define (renumber-file-descriptor old new)
|
||||
(and (duplicate-file-descriptor-to old new)
|
||||
(close-file-descriptor old)))
|
||||
|
||||
(define (file-status file)
|
||||
(if (string? file) (stat file) (fstat file)))
|
||||
|
||||
(define (file-device x) (stat-dev (if (stat? x) x (file-status x))))
|
||||
(define (file-inode x) (stat-ino (if (stat? x) x (file-status x))))
|
||||
(define (file-mode x) (stat-mode (if (stat? x) x (file-status x))))
|
||||
(define (file-num-links x) (stat-nlinks (if (stat? x) x (file-status x))))
|
||||
(define (file-owner x) (stat-uid (if (stat? x) x (file-status x))))
|
||||
(define (file-group x) (stat-gid (if (stat? x) x (file-status x))))
|
||||
(define (file-represented-device x) (stat-rdev (if (stat? x) x (file-status x))))
|
||||
(define (file-size x) (stat-size (if (stat? x) x (file-status x))))
|
||||
(define (file-block-size x) (stat-blksize (if (stat? x) x (file-status x))))
|
||||
(define (file-num-blocks x) (stat-blocks (if (stat? x) x (file-status x))))
|
||||
(define (file-access-time x) (stat-atime (if (stat? x) x (file-status x))))
|
||||
(define (file-modification-time x) (stat-mtime (if (stat? x) x (file-status x))))
|
||||
(define (file-change-time x) (stat-ctime (if (stat? x) x (file-status x))))
|
||||
|
||||
(define (file-regular? x) (S_ISREG (file-mode x)))
|
||||
(define (file-directory? x) (S_ISDIR (file-mode x)))
|
||||
(define (file-character? x) (S_ISCHR (file-mode x)))
|
||||
(define (file-block? x) (S_ISBLK (file-mode x)))
|
||||
(define (file-fifo? x) (S_ISFIFO (file-mode x)))
|
||||
(define (file-link? x) (S_ISLNK (file-mode x)))
|
||||
(define (file-socket? x) (S_ISSOCK (file-mode x)))
|
||||
|
||||
88
lib/chibi/filesystem.stub
Normal file
88
lib/chibi/filesystem.stub
Normal file
|
|
@ -0,0 +1,88 @@
|
|||
|
||||
(c-system-include "sys/types.h")
|
||||
(c-system-include "unistd.h")
|
||||
(c-system-include "dirent.h")
|
||||
|
||||
(define-c-struct DIR
|
||||
finalizer: closedir)
|
||||
|
||||
(define-c-struct dirent
|
||||
(string d_name dirent-name))
|
||||
|
||||
(define-c-struct stat
|
||||
predicate: stat?
|
||||
(dev_t st_dev stat-dev)
|
||||
(ino_t st_ino stat-ino)
|
||||
(mode_t st_mode stat-mode)
|
||||
(nlink_t st_nlink stat-nlinks)
|
||||
(uid_t st_uid stat-uid)
|
||||
(gid_t st_gid stat-gid)
|
||||
(dev_t st_rdev stat-rdev)
|
||||
(off_t st_size stat-size)
|
||||
(blksize_t st_blksize stat-blksize)
|
||||
(blkcnt_t st_blocks stat-blocks)
|
||||
(time_t st_atime stat-atime)
|
||||
(time_t st_mtime stat-mtime)
|
||||
(time_t st_ctime stat-ctime))
|
||||
|
||||
(define-c boolean S_ISREG (mode_t))
|
||||
(define-c boolean S_ISDIR (mode_t))
|
||||
(define-c boolean S_ISCHR (mode_t))
|
||||
(define-c boolean S_ISBLK (mode_t))
|
||||
(define-c boolean S_ISFIFO (mode_t))
|
||||
(define-c boolean S_ISLNK (mode_t))
|
||||
(define-c boolean S_ISSOCK (mode_t))
|
||||
|
||||
;;(define-c-const int ("S_IFMT"))
|
||||
(define-c-const int (file/socket "S_IFSOCK"))
|
||||
(define-c-const int (file/link "S_IFLNK"))
|
||||
(define-c-const int (file/regular "S_IFREG"))
|
||||
(define-c-const int (file/block "S_IFBLK"))
|
||||
(define-c-const int (file/directory "S_IFDIR"))
|
||||
(define-c-const int (file/character "S_IFCHR"))
|
||||
(define-c-const int (file/fifo "S_IFIFO"))
|
||||
(define-c-const int (file/suid "S_ISUID"))
|
||||
(define-c-const int (file/sgid "S_ISGID"))
|
||||
(define-c-const int (file/sticky "S_ISVTX"))
|
||||
;;(define-c-const int ("S_IRWXU"))
|
||||
(define-c-const int (perm/user-read "S_IRUSR"))
|
||||
(define-c-const int (perm/user-write "S_IWUSR"))
|
||||
(define-c-const int (perm/user-execute "S_IXUSR"))
|
||||
;;(define-c-const int ("S_IRWXG"))
|
||||
(define-c-const int (perm/group-read "S_IRGRP"))
|
||||
(define-c-const int (perm/group-write "S_IWGRP"))
|
||||
(define-c-const int (perm/group-execute "S_IXGRP"))
|
||||
;;(define-c-const int ("S_IRWXO"))
|
||||
(define-c-const int (perm/others-read "S_IROTH"))
|
||||
(define-c-const int (perm/others-write "S_IWOTH"))
|
||||
(define-c-const int (perm/others-execute "S_IXOTH"))
|
||||
|
||||
(define-c errno stat (string (result stat)))
|
||||
(define-c errno fstat (int (result stat)))
|
||||
(define-c errno (file-link-status "lstat") (string (result stat)))
|
||||
|
||||
(define-c input-port (open-input-file-descriptor "fdopen")
|
||||
(int (value "r" string)))
|
||||
(define-c output-port (open-output-file-descriptor "fdopen")
|
||||
(int (value "w" string)))
|
||||
|
||||
(define-c errno (delete-file "unlink") (string))
|
||||
(define-c errno (link-file "link") (string string))
|
||||
(define-c errno (symbolic-link-file "symlink") (string string))
|
||||
(define-c errno (rename-file "rename") (string string))
|
||||
|
||||
(define-c non-null-string (current-directory "getcwd")
|
||||
((result (array char (auto-expand arg1))) (value 256 int)))
|
||||
|
||||
(define-c errno (create-directory "mkdir") (string int))
|
||||
(define-c errno (delete-directory "rmdir") (string))
|
||||
|
||||
(define-c (free DIR) opendir (string))
|
||||
(define-c dirent readdir ((link DIR)))
|
||||
|
||||
(define-c int (duplicate-file-descriptor "dup") (int))
|
||||
(define-c errno (duplicate-file-descriptor-to "dup2") (int int))
|
||||
(define-c errno (close-file-descriptor "close") (int))
|
||||
|
||||
(define-c errno (open-pipe "pipe") ((result (array int 2))))
|
||||
(define-c errno (make-fifo "mkfifo") (string (default #o644 int)))
|
||||
|
|
@ -1,12 +0,0 @@
|
|||
|
||||
(define-module (chibi posix)
|
||||
(export open-input-fd open-output-fd pipe
|
||||
delete-file link-file symbolic-link-file rename-file
|
||||
directory-files create-directory delete-directory
|
||||
current-seconds
|
||||
waitpid exit
|
||||
)
|
||||
(import-immutable (scheme))
|
||||
(include-shared "posix")
|
||||
(include "posix.scm"))
|
||||
|
||||
|
|
@ -1,10 +0,0 @@
|
|||
|
||||
(define (directory-fold dir kons knil)
|
||||
(let ((dir (opendir dir)))
|
||||
(let lp ((res knil))
|
||||
(let ((file (readdir dir)))
|
||||
(if file (lp (kons (dirent-name file) res)) res)))))
|
||||
|
||||
(define (directory-files dir)
|
||||
(directory-fold dir cons '()))
|
||||
|
||||
|
|
@ -1,40 +0,0 @@
|
|||
|
||||
(c-system-include "sys/types.h")
|
||||
(c-system-include "sys/wait.h")
|
||||
(c-system-include "time.h")
|
||||
(c-system-include "unistd.h")
|
||||
(c-system-include "dirent.h")
|
||||
|
||||
(define-c-struct DIR
|
||||
finalizer: closedir)
|
||||
|
||||
(define-c-struct dirent
|
||||
(string d_name dirent-name))
|
||||
|
||||
(define-c input-port (open-input-fd "fdopen") (int (value "r" string)))
|
||||
(define-c output-port (open-output-fd "fdopen") (int (value "w" string)))
|
||||
|
||||
(define-c errno (delete-file "unlink") (string))
|
||||
(define-c errno (link-file "link") (string string))
|
||||
(define-c errno (symbolic-link-file "symlink") (string string))
|
||||
(define-c errno (rename-file "rename") (string string))
|
||||
|
||||
(define-c non-null-string (current-directory "getcwd")
|
||||
((result (array char (auto-expand arg1))) (value 256 int)))
|
||||
(define-c errno (create-directory "mkdir") (string int))
|
||||
(define-c errno (delete-directory "rmdir") (string))
|
||||
|
||||
(define-c (free DIR) opendir (string))
|
||||
(define-c dirent readdir ((link DIR)))
|
||||
|
||||
(define-c int (duplicate-fd "dup") (int))
|
||||
|
||||
(define-c pid_t fork ())
|
||||
(define-c pid_t waitpid (int (result int) int))
|
||||
(define-c void exit (int))
|
||||
(define-c int (execute execvp) (string (array string)))
|
||||
|
||||
(define-c errno pipe ((result (array int 2))))
|
||||
|
||||
(define-c time_t (current-seconds "time") ((value NULL)))
|
||||
|
||||
17
lib/chibi/process.module
Normal file
17
lib/chibi/process.module
Normal file
|
|
@ -0,0 +1,17 @@
|
|||
|
||||
(define-module (chibi process)
|
||||
(export exit sleep fork kill execute waitpid
|
||||
set-signal-action! make-signal-set signal-set-contains?
|
||||
signal-set-fill! signal-set-add! signal-set-delete!
|
||||
current-signal-mask
|
||||
signal-mask-block! signal-mask-unblock! signal-mask-set!
|
||||
signal/hang-up signal/interrupt signal/quit
|
||||
signal/illegal signal/abort signal/fpe
|
||||
signal/kill signal/segv signal/pipe
|
||||
signal/alarm signal/term signal/user1
|
||||
signal/user2 signal/child signal/continue
|
||||
signal/stop signal/tty-stop signal/tty-input
|
||||
signal/tty-output)
|
||||
(import-immutable (scheme))
|
||||
(include-shared "process"))
|
||||
|
||||
69
lib/chibi/process.stub
Normal file
69
lib/chibi/process.stub
Normal file
|
|
@ -0,0 +1,69 @@
|
|||
|
||||
(c-system-include "sys/types.h")
|
||||
(c-system-include "sys/wait.h")
|
||||
(c-system-include "signal.h")
|
||||
(c-system-include "unistd.h")
|
||||
|
||||
(define-c-struct siginfo
|
||||
predicate: signal-info?
|
||||
(int si_signo signal-number)
|
||||
(int si_errno signal-error-number)
|
||||
(int si_code signal-code)
|
||||
(pid_t si_pid signal-pid)
|
||||
(uid_t si_uid signal-uid)
|
||||
(int si_status signal-status)
|
||||
(clock_t si_utime signal-user-time)
|
||||
(clock_t si_stime signal-system-time))
|
||||
|
||||
(define-c-type sigset_t
|
||||
predicate: signal-set?)
|
||||
|
||||
(define-c-const int (signal/hang-up "SIGHUP"))
|
||||
(define-c-const int (signal/interrupt "SIGINT"))
|
||||
(define-c-const int (signal/quit "SIGQUIT"))
|
||||
(define-c-const int (signal/illegal "SIGILL"))
|
||||
(define-c-const int (signal/abort "SIGABRT"))
|
||||
(define-c-const int (signal/fpe "SIGFPE"))
|
||||
(define-c-const int (signal/kill "SIGKILL"))
|
||||
(define-c-const int (signal/segv "SIGSEGV"))
|
||||
(define-c-const int (signal/pipe "SIGPIPE"))
|
||||
(define-c-const int (signal/alarm "SIGALRM"))
|
||||
(define-c-const int (signal/term "SIGTERM"))
|
||||
(define-c-const int (signal/user1"SIGUSR1"))
|
||||
(define-c-const int (signal/user2 "SIGUSR2"))
|
||||
(define-c-const int (signal/child "SIGCHLD"))
|
||||
(define-c-const int (signal/continue "SIGCONT"))
|
||||
(define-c-const int (signal/stop "SIGSTOP"))
|
||||
(define-c-const int (signal/tty-stop "SIGTSTP"))
|
||||
(define-c-const int (signal/tty-input "SIGTTIN"))
|
||||
(define-c-const int (signal/tty-output "SIGTTOU"))
|
||||
|
||||
(c-include "signal.c")
|
||||
|
||||
(define-c sexp (set-signal-action! "sexp_set_signal_action")
|
||||
((value ctx sexp) sexp sexp))
|
||||
|
||||
(define-c errno (make-signal-set "sigemptyset") ((result sigset_t)))
|
||||
(define-c errno (signal-set-fill! "sigfillset") (sigset_t))
|
||||
(define-c errno (signal-set-add! "sigaddset") (sigset_t int))
|
||||
(define-c errno (signal-set-delete! "sigaddset") (sigset_t int))
|
||||
(define-c boolean (signal-set-contains? "sigismember") (sigset_t int))
|
||||
|
||||
(define-c errno (signal-mask-block! "sigprocmask")
|
||||
((value SIG_BLOCK int) sigset_t (value NULL sigset_t)))
|
||||
(define-c errno (signal-mask-unblock! "sigprocmask")
|
||||
((value SIG_UNBLOCK int) sigset_t (value NULL sigset_t)))
|
||||
(define-c errno (signal-mask-set! "sigprocmask")
|
||||
((value SIG_SETMASK int) sigset_t (value NULL sigset_t)))
|
||||
(define-c errno (current-signal-mask "sigprocmask")
|
||||
((value SIG_BLOCK int) (value NULL sigset_t) (result sigset_t)))
|
||||
|
||||
(define-c pid_t fork ())
|
||||
;;(define-c pid_t wait ((result int)))
|
||||
(define-c pid_t waitpid (int (result int) int))
|
||||
(define-c errno kill (int int))
|
||||
;;(define-c errno raise (int))
|
||||
(define-c unsigned-int sleep (unsigned-int))
|
||||
(define-c void exit (int))
|
||||
(define-c int (execute execvp) (string (array string)))
|
||||
|
||||
11
lib/chibi/time.module
Normal file
11
lib/chibi/time.module
Normal file
|
|
@ -0,0 +1,11 @@
|
|||
|
||||
(define-module (chibi time)
|
||||
(export current-seconds get-time-of-day set-time-of-day!
|
||||
seconds->time seconds->string time->seconds time->string
|
||||
timeval-seconds timeval-microseconds
|
||||
timezone-offset timezone-dst-time
|
||||
time-second time-minute time-hour time-day time-month time-year
|
||||
time-day-of-week time-day-of-year time-dst?)
|
||||
(import-immutable (scheme))
|
||||
(include-shared "time"))
|
||||
|
||||
45
lib/chibi/time.stub
Normal file
45
lib/chibi/time.stub
Normal file
|
|
@ -0,0 +1,45 @@
|
|||
|
||||
(c-system-include "time.h")
|
||||
(c-system-include "sys/time.h")
|
||||
|
||||
(define-c-struct tm
|
||||
(int tm_sec time-second)
|
||||
(int tm_min time-minute)
|
||||
(int tm_hour time-hour)
|
||||
(int tm_mday time-day)
|
||||
(int tm_mon time-month)
|
||||
(int tm_year time-year)
|
||||
(int tm_wday time-day-of-week)
|
||||
(int tm_yday time-day-of-year)
|
||||
(int tm_isdst time-dst?))
|
||||
|
||||
(define-c-struct timeval
|
||||
predicate: timeval?
|
||||
(time_t tv_sec timeval-seconds)
|
||||
(int tv_usec timeval-microseconds))
|
||||
|
||||
(define-c-struct timezone
|
||||
predicate: timezone?
|
||||
(int tz_minuteswest timezone-offset)
|
||||
(int tz_dsttime timezone-dst-time))
|
||||
|
||||
(define-c time_t (current-seconds "time") ((value NULL)))
|
||||
|
||||
(define-c errno (get-time-of-day "gettimeofday")
|
||||
((result timeval) (result timezone)))
|
||||
|
||||
(define-c errno (set-time-of-day! "settimeofday")
|
||||
((maybe-null timeval) (maybe-null default NULL timezone)))
|
||||
|
||||
(define-c non-null-pointer (seconds->time "localtime_r")
|
||||
((pointer time_t) (result tm)))
|
||||
|
||||
(define-c time_t (time->seconds "mktime")
|
||||
(tm))
|
||||
|
||||
(define-c non-null-string (seconds->string "ctime_r")
|
||||
((pointer time_t) (result (array char 64))))
|
||||
|
||||
(define-c non-null-string (time->string "asctime_r")
|
||||
(tm (result (array char 64))))
|
||||
|
||||
|
|
@ -18,7 +18,7 @@
|
|||
lset<= lset= lset-adjoin lset-union lset-union! lset-intersection
|
||||
lset-intersection! lset-difference lset-difference! lset-xor lset-xor!
|
||||
lset-diff+intersection lset-diff+intersection!)
|
||||
(import-immutable (scheme))
|
||||
(import (scheme))
|
||||
(include "1/predicates.scm"
|
||||
"1/selectors.scm"
|
||||
"1/search.scm"
|
||||
|
|
|
|||
|
|
@ -139,6 +139,7 @@
|
|||
|
||||
(define *types* '())
|
||||
(define *funcs* '())
|
||||
(define *consts* '())
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; type objects
|
||||
|
|
@ -202,10 +203,12 @@
|
|||
;; type predicates
|
||||
|
||||
(define (signed-int-type? type)
|
||||
(memq type '(signed-char short int long)))
|
||||
(memq type '(signed-char short int long boolean)))
|
||||
|
||||
(define (unsigned-int-type? type)
|
||||
(memq type '(unsigned-char unsigned-short unsigned-int unsigned-long size_t pid_t)))
|
||||
(memq type '(unsigned-char unsigned-short unsigned-int unsigned-long
|
||||
size_t off_t time_t clock_t dev_t ino_t mode_t nlink_t
|
||||
uid_t gid_t pid_t blksize_t blkcnt_t sigval_t)))
|
||||
|
||||
(define (int-type? type)
|
||||
(or (signed-int-type? type) (unsigned-int-type? type)))
|
||||
|
|
@ -214,14 +217,23 @@
|
|||
(memq type '(float double long-double long-long-double)))
|
||||
|
||||
(define (string-type? type)
|
||||
(memq type '(char* string env-string non-null-string)))
|
||||
(or (memq type '(char* string env-string non-null-string))
|
||||
(and (vector? type)
|
||||
(type-array type)
|
||||
(not (type-pointer? type))
|
||||
(eq? 'char (type-base type)))))
|
||||
|
||||
(define (error-type? type)
|
||||
(memq type '(errno non-null-string)))
|
||||
(memq type '(errno non-null-string non-null-pointer)))
|
||||
|
||||
(define (array-type? type)
|
||||
(and (type-array type) (not (eq? 'char (type-base type)))))
|
||||
|
||||
(define (basic-type? type)
|
||||
(let ((type (parse-type type)))
|
||||
(and (not (type-array type))
|
||||
(not (assq (type-base type) *types*)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; function objects
|
||||
|
||||
|
|
@ -250,7 +262,7 @@
|
|||
(cond
|
||||
((type-result? type)
|
||||
(lp (cdr ls) (+ i 1) (cons type results) (cons type c-args) s-args))
|
||||
((type-value type)
|
||||
((and (type-value type) (not (type-default? type)))
|
||||
(lp (cdr ls) (+ i 1) results (cons type c-args) s-args))
|
||||
(else
|
||||
(lp (cdr ls) (+ i 1) results (cons type c-args) (cons type s-args)))
|
||||
|
|
@ -303,10 +315,8 @@
|
|||
(define (collect) (if (= i from) res (cons (substring str from i) res)))
|
||||
(cond
|
||||
((>= i len) (string-concatenate-reverse (collect)))
|
||||
((eqv? c (string-ref str i))
|
||||
(lp (+ i 1) (+ i 1) (cons r (collect))))
|
||||
(else
|
||||
(lp from (+ i 1) res))))))
|
||||
((eqv? c (string-ref str i)) (lp (+ i 1) (+ i 1) (cons r (collect))))
|
||||
(else (lp from (+ i 1) res))))))
|
||||
|
||||
(define (string-scan c str . o)
|
||||
(let ((limit (string-length str)))
|
||||
|
|
@ -349,9 +359,21 @@
|
|||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; naming
|
||||
|
||||
(define (c-char? c)
|
||||
(or (char-alphabetic? c) (char-numeric? c) (memv c '(#\_ #\- #\! #\?))))
|
||||
|
||||
(define (c-escape str)
|
||||
(let ((len (string-length str)))
|
||||
(let lp ((from 0) (i 0) (res '()))
|
||||
(define (collect) (if (= i from) res (cons (substring str from i) res)))
|
||||
(cond
|
||||
((>= i len) (string-concatenate-reverse (collect)))
|
||||
((not (c-char? (string-ref str i))) (lp (+ i 1) (+ i 1) (cons "_" (cons (number->string (char->integer (string-ref str i)) 16) (collect)))))
|
||||
(else (lp from (+ i 1) res))))))
|
||||
|
||||
(define (mangle x)
|
||||
(string-replace
|
||||
(string-replace (string-replace (x->string x) #\- "_") #\? "_p")
|
||||
(string-replace (string-replace (c-escape (x->string x)) #\- "_") #\? "_p")
|
||||
#\! "_x"))
|
||||
|
||||
(define (generate-stub-name sym)
|
||||
|
|
@ -367,20 +389,38 @@
|
|||
(apply cat args)
|
||||
(newline))
|
||||
|
||||
(define (c-include header)
|
||||
(cat "\n#include \"" header "\"\n"))
|
||||
|
||||
(define (c-system-include header)
|
||||
(cat "\n#include <" header ">\n"))
|
||||
|
||||
(define (parse-struct-like ls)
|
||||
(map (lambda (x) (if (pair? x) (cons (parse-type (car x)) (cdr x)) x)) ls))
|
||||
|
||||
(define-syntax define-struct-like
|
||||
(er-macro-transformer
|
||||
(lambda (expr rename compare)
|
||||
(set! *types*
|
||||
`((,(cadr expr)
|
||||
,@(parse-struct-like (cddr expr)))
|
||||
,@*types*))
|
||||
`(cat "\nstatic sexp_uint_t " ,(type-id-name (cadr expr)) ";\n"))))
|
||||
|
||||
(define-syntax define-c-struct
|
||||
(er-macro-transformer
|
||||
(lambda (expr rename compare)
|
||||
(set! *types*
|
||||
(cons (map (lambda (x)
|
||||
(if (pair? x)
|
||||
(cons (parse-type (car x)) (cdr x))
|
||||
x))
|
||||
(cdr expr))
|
||||
*types*))
|
||||
`(cat "\nstatic sexp_uint_t " ,(type-id-name (cadr expr)) ";\n"))))
|
||||
`(define-struct-like ,(cadr expr) type: struct ,@(cddr expr)))))
|
||||
|
||||
(define-syntax define-c-class
|
||||
(er-macro-transformer
|
||||
(lambda (expr rename compare)
|
||||
`(define-struct-like ,(cadr expr) type: class ,@(cddr expr)))))
|
||||
|
||||
(define-syntax define-c-type
|
||||
(er-macro-transformer
|
||||
(lambda (expr rename compare)
|
||||
`(define-struct-like ,(cadr expr) ,@(cddr expr)))))
|
||||
|
||||
(define-syntax define-c
|
||||
(er-macro-transformer
|
||||
|
|
@ -388,6 +428,12 @@
|
|||
(set! *funcs* (cons (parse-func (cdr expr)) *funcs*))
|
||||
#f)))
|
||||
|
||||
(define-syntax define-c-const
|
||||
(er-macro-transformer
|
||||
(lambda (expr rename compare)
|
||||
(set! *consts*
|
||||
(cons (cons (parse-type (cadr expr)) (cddr expr)) *consts*)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; C code generation
|
||||
|
||||
|
|
@ -398,6 +444,8 @@
|
|||
(cat "((" val "), SEXP_VOID)"))
|
||||
((or (eq? base 'sexp) (error-type? base))
|
||||
(cat val))
|
||||
((eq? base 'boolean)
|
||||
(cat "sexp_make_boolean(" val ")"))
|
||||
((eq? base 'time_t)
|
||||
(cat "sexp_make_integer(ctx, sexp_shift_epoch(" val "))"))
|
||||
((int-type? base)
|
||||
|
|
@ -422,7 +470,11 @@
|
|||
(ctype
|
||||
(cat "sexp_make_cpointer(ctx, " (type-id-name base) ", "
|
||||
val ", " (or (and (pair? o) (car o)) "SEXP_FALSE") ", "
|
||||
(if (type-free? type) 1 0) ")"))
|
||||
(if (or (type-free? type)
|
||||
(and (type-result? type) (not (basic-type? type))))
|
||||
1
|
||||
0)
|
||||
")"))
|
||||
(else
|
||||
(error "unknown type" base))))))))
|
||||
|
||||
|
|
@ -432,8 +484,10 @@
|
|||
(cond
|
||||
((eq? base 'sexp)
|
||||
(cat val))
|
||||
((eq? base 'boolean)
|
||||
(cat "sexp_truep(" val ")"))
|
||||
((eq? base 'time_t)
|
||||
(cat "sexp_uint_value(sexp_unshift_epoch(" val "))"))
|
||||
(cat "sexp_unshift_epoch(sexp_uint_value(" val "))"))
|
||||
((signed-int-type? base)
|
||||
(cat "sexp_sint_value(" val ")"))
|
||||
((unsigned-int-type? base)
|
||||
|
|
@ -462,6 +516,7 @@
|
|||
((float-type? base) "sexp_flonump")
|
||||
((string-type? base) "sexp_stringp")
|
||||
((eq? base 'char) "sexp_charp")
|
||||
((eq? base 'boolean) "sexp_booleanp")
|
||||
(else #f))))
|
||||
|
||||
(define (type-name type)
|
||||
|
|
@ -469,6 +524,7 @@
|
|||
(cond
|
||||
((int-type? base) "integer")
|
||||
((float-type? base) "flonum")
|
||||
((eq? 'boolean base) "int")
|
||||
(else base))))
|
||||
|
||||
(define (base-type-c-name base)
|
||||
|
|
@ -479,12 +535,15 @@
|
|||
(define (type-c-name type)
|
||||
(let* ((type (parse-type type))
|
||||
(base (type-base type))
|
||||
(struct? (assq base *types*)))
|
||||
(type-spec (assq base *types*))
|
||||
(struct-type
|
||||
(cond ((and type-spec (memq 'type: type-spec)) => cadr)
|
||||
(else #f))))
|
||||
(string-append
|
||||
(if (type-const? type) "const " "")
|
||||
(if struct? "struct " "")
|
||||
(if struct-type (string-append (symbol->string struct-type) " ") "")
|
||||
(string-replace (base-type-c-name base) #\- " ")
|
||||
(if struct? "*" "")
|
||||
(if type-spec "*" "")
|
||||
(if (type-pointer? type) "*" ""))))
|
||||
|
||||
(define (check-type arg type)
|
||||
|
|
@ -515,7 +574,7 @@
|
|||
(array (type-array type))
|
||||
(base-type (type-base type)))
|
||||
(cond
|
||||
(array
|
||||
((and array (not (string-type? type)))
|
||||
(cond
|
||||
((number? array)
|
||||
(cat " if (!sexp_listp(ctx, " arg ")"
|
||||
|
|
@ -544,9 +603,11 @@
|
|||
" if (! " (lambda () (check-type arg type)) ")\n"
|
||||
" return sexp_type_exception(ctx, \"not "
|
||||
(definite-article (type-name type)) "\", " arg ");\n"))
|
||||
((eq? 'sexp base-type))
|
||||
((string-type? type)
|
||||
(write-validator arg 'string))
|
||||
(else
|
||||
(if (not (eq? 'sexp (type-base type)))
|
||||
(display "WARNING: don't know how to validate: " (current-error-port)))
|
||||
(display "WARNING: don't know how to validate: " (current-error-port))
|
||||
(write type (current-error-port))
|
||||
(newline (current-error-port))
|
||||
(write type)))))))
|
||||
|
|
@ -588,7 +649,9 @@
|
|||
(gc-vars (if preserve-res? (cons "res" gc-vars) gc-vars))
|
||||
(sexps (if preserve-res? '() '("res")))
|
||||
(num-gc-vars (length gc-vars))
|
||||
(ints (if (or return-res? (eq? 'non-null-string (type-base ret-type)))
|
||||
(ints (if (or return-res?
|
||||
(memq (type-base ret-type)
|
||||
'(non-null-string non-null-pointer)))
|
||||
'()
|
||||
'("err")))
|
||||
(ints (if (or (array-type? ret-type)
|
||||
|
|
@ -596,8 +659,9 @@
|
|||
(any array-type? scheme-args))
|
||||
(cons "i" ints)
|
||||
ints)))
|
||||
(if(eq? 'non-null-string (type-base ret-type))
|
||||
(cat " char *err;\n"))
|
||||
(case (type-base ret-type)
|
||||
((non-null-string) (cat " char *err;\n"))
|
||||
((non-null-pointer) (cat " void *err;\n")))
|
||||
(cond
|
||||
((pair? ints)
|
||||
(cat " int " (car ints))
|
||||
|
|
@ -624,6 +688,13 @@
|
|||
(append (if (type-array ret-type) (list ret-type) '())
|
||||
results
|
||||
(remove type-result? (filter type-array scheme-args))))
|
||||
(for-each
|
||||
(lambda (arg)
|
||||
(cond
|
||||
((and (type-pointer? arg) (basic-type? arg))
|
||||
(cat " " (type-c-name (type-base arg))
|
||||
" tmp" (type-index arg) ";\n"))))
|
||||
scheme-args)
|
||||
(cond
|
||||
((pair? sexps)
|
||||
(cat " sexp " (car sexps))
|
||||
|
|
@ -657,7 +728,7 @@
|
|||
";\n"
|
||||
" tmp" (type-index a) " = buf" (type-index a) ";\n"))))
|
||||
(cond
|
||||
((and (not (type-result? a)) (type-array a))
|
||||
((and (not (type-result? a)) (type-array a) (not (string-type? a)))
|
||||
(if (not (number? (type-array a)))
|
||||
(cat " tmp" (type-index a)
|
||||
" = (" (type-c-name (type-base a)) "*) malloc("
|
||||
|
|
@ -670,9 +741,45 @@
|
|||
";\n"
|
||||
" }\n")
|
||||
(if (not (number? (type-array a)))
|
||||
(cat " tmp" (type-index a) "[i] = NULL;\n")))))
|
||||
(cat " tmp" (type-index a) "[i] = NULL;\n")))
|
||||
((and (type-result? a) (not (basic-type? a))
|
||||
(not (type-free? a)) (not (type-auto-expand? a))
|
||||
(or (not (type-array a))
|
||||
(not (integer? (get-array-length func a)))))
|
||||
(cat " tmp" (type-index a) " = malloc(sizeof(tmp" (type-index a)
|
||||
"[0]));\n"))
|
||||
((and (type-pointer? a) (basic-type? a))
|
||||
(cat " tmp" (type-index a) " = "
|
||||
(lambda ()
|
||||
(scheme->c-converter
|
||||
a
|
||||
(string-append "arg" (type-index-string a))))
|
||||
";\n"))))
|
||||
(func-c-args func)))
|
||||
|
||||
(define (write-actual-parameter func arg)
|
||||
(cond
|
||||
((and (not (type-default? arg)) (type-value arg))
|
||||
=> (lambda (x)
|
||||
(cond
|
||||
((any (lambda (y)
|
||||
(and (type-array y)
|
||||
(eq? x (get-array-length func y))))
|
||||
(func-c-args func))
|
||||
=> (lambda (y) (cat "len" (type-index y))))
|
||||
(else (write x)))))
|
||||
((or (type-result? arg) (type-array arg))
|
||||
(cat (if (or (type-pointer? arg) (type-free? arg) (basic-type? arg))
|
||||
"&"
|
||||
"")
|
||||
"tmp" (type-index arg)))
|
||||
((and (type-pointer? arg) (basic-type? arg))
|
||||
(cat "&tmp" (type-index arg)))
|
||||
(else
|
||||
(scheme->c-converter
|
||||
arg
|
||||
(string-append "arg" (type-index-string arg))))))
|
||||
|
||||
(define (write-call func)
|
||||
(let ((ret-type (func-ret-type func))
|
||||
(c-name (func-c-name func))
|
||||
|
|
@ -691,23 +798,7 @@
|
|||
(for-each
|
||||
(lambda (arg)
|
||||
(if (> (type-index arg) 0) (cat ", "))
|
||||
(cond
|
||||
((or (type-result? arg) (type-array arg))
|
||||
(cat (if (or (type-pointer? arg) (type-array arg)) "" "&")
|
||||
"tmp" (type-index arg)))
|
||||
((type-value arg)
|
||||
=> (lambda (x)
|
||||
(cond
|
||||
((any (lambda (y)
|
||||
(and (type-array y)
|
||||
(eq? x (get-array-length func y))))
|
||||
(func-c-args func))
|
||||
=> (lambda (y) (cat "len" (type-index y))))
|
||||
(else (write x)))))
|
||||
(else
|
||||
(scheme->c-converter
|
||||
arg
|
||||
(string-append "arg" (type-index-string arg))))))
|
||||
(write-actual-parameter func arg))
|
||||
c-args)
|
||||
(cat ")"))
|
||||
(cond
|
||||
|
|
@ -762,7 +853,10 @@
|
|||
(results (func-results func)))
|
||||
(if error-res?
|
||||
(cat " if ("
|
||||
(if (eq? 'non-null-string (type-base (func-ret-type func))) "!" "")
|
||||
(if (memq (type-base (func-ret-type func))
|
||||
'(non-null-string non-null-pointer))
|
||||
"!"
|
||||
"")
|
||||
"err) {\n"
|
||||
(cond
|
||||
((any type-auto-expand? (func-c-args func))
|
||||
|
|
@ -847,10 +941,21 @@
|
|||
"}\n\n"))
|
||||
|
||||
(define (write-func-binding func)
|
||||
(cat " sexp_define_foreign(ctx, env, "
|
||||
(let ((default (and (pair? (func-scheme-args func))
|
||||
(type-default? (car (reverse (func-scheme-args func))))
|
||||
(car (reverse (func-scheme-args func))))))
|
||||
(cat (if default
|
||||
" sexp_define_foreign_opt(ctx, env, "
|
||||
" sexp_define_foreign(ctx, env, ")
|
||||
(lambda () (write (symbol->string (func-scheme-name func))))
|
||||
", " (length (func-scheme-args func)) ", "
|
||||
(func-stub-name func) ");\n"))
|
||||
(func-stub-name func)
|
||||
(if default ", " "")
|
||||
(if default
|
||||
(lambda ()
|
||||
(c->scheme-converter default (type-value default)))
|
||||
"")
|
||||
");\n")))
|
||||
|
||||
(define (write-type type)
|
||||
(let ((name (car type))
|
||||
|
|
@ -975,6 +1080,13 @@
|
|||
*funcs*)))))))
|
||||
type)))
|
||||
|
||||
(define (write-const const)
|
||||
(let ((scheme-name (if (pair? (cadr const)) (caadr const) (cadr const)))
|
||||
(c-name (if (pair? (cadr const)) (cadadr const) (mangle (cadr const)))))
|
||||
(cat " name = sexp_intern(ctx, \"" scheme-name "\");\n"
|
||||
" sexp_env_define(ctx, env, name, tmp="
|
||||
(lambda () (c->scheme-converter (car const) c-name)) ");\n")))
|
||||
|
||||
(define (write-utilities)
|
||||
(define (input-env-string? x)
|
||||
(and (eq? 'env-string (type-base x)) (not (type-result? x))))
|
||||
|
|
@ -1001,6 +1113,7 @@
|
|||
(cat "sexp sexp_init_library (sexp ctx, sexp env) {\n"
|
||||
" sexp_gc_var2(name, tmp);\n"
|
||||
" sexp_gc_preserve2(ctx, name, tmp);\n")
|
||||
(for-each write-const *consts*)
|
||||
(for-each write-type *types*)
|
||||
(for-each write-func-binding *funcs*)
|
||||
(cat " sexp_gc_release2(ctx);\n"
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue