Skip to content

Commit

Permalink
!5 S7: define-library and import after S7 init
Browse files Browse the repository at this point in the history 
* S7: define-library and import after init
  • Loading branch information
@da-liii
da-liii committed Jul 10, 2024
1 parent 51bd32c commit f1064ba
Showing 1 changed file with 92 additions and 0 deletions.
92 changes: 92 additions & 0 deletions repl.c
View file
Original file line number Diff line number Diff line change
Expand Up @@ -12,6 +12,95 @@

#include "s7.h"

char* str_r7rs_define_library=
"(define-macro (define-library libname . body) ; |(lib name)| -> environment\n"
" `(define ,(symbol (object->string libname))\n"
" (with-let (sublet (unlet)\n"
" (cons 'import import)\n"
" (cons '*export* ())\n"
" (cons 'export (define-macro (,(gensym) . names)\n"
" `(set! *export* (append ',names *export*)))))\n"
" ,@body\n"
" (apply inlet\n"
" (map (lambda (entry)\n"
" (if (or (member (car entry) '(*export* export import))\n"
" (and (pair? *export*)\n"
" (not (member (car entry) *export*))))\n"
" (values)\n"
" entry))\n"
" (curlet))))))\n";
char* str_r7rs_library_filename=
"(unless (defined? 'r7rs-import-library-filename)\n"
" (define (r7rs-import-library-filename libs)\n"
" (when (pair? libs)\n"
" (let ((lib-filename (let loop ((lib (if (memq (caar libs) '(only except prefix rename))\n"
" (cadar libs)\n"
" (car libs)))\n"
" (name \"\"))\n"
" (set! name (string-append name (symbol->string (car lib))))\n"
" (if (null? (cdr lib))\n"
" (string-append name \".scm\")\n"
" (begin\n"
" (set! name (string-append name \"/\"))\n"
" (loop (cdr lib) name))))))\n"
" (unless (member lib-filename (*s7* 'file-names))\n"
" (load lib-filename)))\n"
" (r7rs-import-library-filename (cdr libs)))))\n";
char* str_r7rs_import=
"(define-macro (import . libs)\n"
" `(begin\n"
" (r7rs-import-library-filename ',libs)\n"
" (varlet (curlet)\n"
" ,@(map (lambda (lib)\n"
" (case (car lib)\n"
" ((only)\n"
" `((lambda (e names)\n"
" (apply inlet\n"
" (map (lambda (name)\n"
" (cons name (e name)))\n"
" names)))\n"
" (symbol->value (symbol (object->string (cadr ',lib))))\n"
" (cddr ',lib)))\n"
" ((except)\n"
" `((lambda (e names)\n"
" (apply inlet\n"
" (map (lambda (entry)\n"
" (if (member (car entry) names)\n"
" (values)\n"
" entry))\n"
" e)))\n"
" (symbol->value (symbol (object->string (cadr ',lib))))\n"
" (cddr ',lib)))\n"
" ((prefix)\n"
" `((lambda (e prefx)\n"
" (apply inlet\n"
" (map (lambda (entry)\n"
" (cons (string->symbol \n"
" (string-append (symbol->string prefx) \n"
" (symbol->string (car entry)))) \n"
" (cdr entry)))\n"
" e)))\n"
" (symbol->value (symbol (object->string (cadr ',lib))))\n"
" (caddr ',lib)))\n"
" ((rename)\n"
" `((lambda (e names)\n"
" (apply inlet\n"
" (map (lambda (entry)\n"
" (let ((info (assoc (car entry) names)))\n"
" (if info\n"
" (cons (cadr info) (cdr entry))\n"
" entry))) \n"
" e)))\n"
" (symbol->value (symbol (object->string (cadr ',lib))))\n"
" (cddr ',lib)))\n"
" (else\n"
" `(let ((sym (symbol (object->string ',lib))))\n"
" (if (not (defined? sym))\n"
" (format () \"~A not loaded~%\" sym)\n"
" (symbol->value sym))))))\n"
" libs))))\n";


#ifndef _MSC_VER
static char*
realdir (s7_scheme* sc, const char* filename) {
Expand Down Expand Up @@ -56,6 +145,9 @@ main (int argc, char** argv) {
s7_scheme* sc;

sc= s7_init ();
s7_eval_c_string (sc, str_r7rs_define_library);
s7_eval_c_string (sc, str_r7rs_library_filename);
s7_eval_c_string (sc, str_r7rs_import);
if (argc >= 2) {
if (strcmp (argv[1], "-e") == 0) /* repl -e '(+ 1 2)' */
{
Expand Down

0 comments on commit f1064ba

Please sign in to comment.