29 Commits

Author SHA1 Message Date
Arthur Barraux fa7f8d39d8 update splash screen
Build project / build (push) Successful in 23s
2026-01-14 20:38:33 +01:00
Arthur Barraux 23036cf3d3 warranty 0 memoey leak
Build project / build (push) Successful in 58s
2026-01-14 20:24:37 +01:00
Arthur Barraux d0afd4f304 patch file_completion crash
Build project / build (push) Successful in 1m0s
2026-01-13 15:20:18 +01:00
Arthur Barraux de4fa78221 Merge remote-tracking branch 'gitea/main'
Build project / build (push) Successful in 48s
2026-01-11 19:41:57 +01:00
Arthur Barraux fc93832130 Syntax highlighting and comment 2026-01-11 19:41:30 +01:00
arthur 39e07902f4 Update README.md
Build project / build (push) Successful in 24s
2026-01-09 15:03:08 +01:00
Arthur Barraux 815114923d Add prefix feature
Build project / build (push) Successful in 56s
2026-01-09 14:54:07 +01:00
arthur 410f382592 Add go to end of word function
Build project / build (push) Successful in 1m22s
2025-12-24 14:50:14 +01:00
arthur 80c0bf73e0 Update README.md
Build project / build (push) Successful in 1m1s
2025-12-08 00:25:05 +01:00
arthur d4ee0d86c2 Update .gitea/workflows/build.yml
Build project / build (push) Failing after 2m18s
2025-12-04 01:34:33 +01:00
arthur c06c820dfb Patch path complete and read char lisp function
Build project / build (push) Has been cancelled
2025-11-07 16:23:56 +01:00
arthur 5588b0a8d7 add path autocomplete
Build project / build (push) Has been cancelled
2025-11-05 15:49:01 +01:00
arthur 419e924650 Add search function
Build project / build (push) Has been cancelled
2025-11-03 16:45:23 +01:00
arthur 6a201b3ebc delete line macro
Build project / build (push) Has been cancelled
2025-11-03 16:05:25 +01:00
arthur 1d253e51ef Update README.md
Build project / build (push) Failing after 3m27s
2025-11-01 13:22:10 +01:00
Arthur Barraux 42f82e2e0d add packages
Build project / build (push) Has been cancelled
2025-11-01 13:03:07 +01:00
arthur fa32f4b177 Update src/init.c
Build project / build (push) Has been cancelled
2025-10-31 09:10:57 +01:00
arthur 65f997e964 Update install.sh
Build project / build (push) Has been cancelled
2025-10-31 09:09:20 +01:00
Arthur Barraux 7eaf6913cb Merge remote-tracking branch 'gitea/main'
Build project / build (push) Has been cancelled
2025-10-30 18:18:12 +01:00
Arthur Barraux 8f7dcf3534 Adding installer script 2025-10-30 18:17:19 +01:00
arthur d8c6b9ace3 Update README.md
Build project / build (push) Has been cancelled
2025-10-28 09:16:36 +01:00
arthur d0173d7308 Update README.md
Build project / build (push) Has been cancelled
2025-10-28 09:02:29 +01:00
arthur 40fc234eeb Update .gitea/workflows/build.yml
Build project / build (push) Failing after 39s
2025-10-18 15:35:57 +02:00
Arthur Barraux 756deba83e remove .cache repo for cleaning
Build project / build (push) Failing after 33s
2025-10-18 15:12:06 +02:00
Arthur Barraux 85e8067e41 clean up the repo
Build project / build (push) Failing after 1m22s
2025-10-18 15:06:23 +02:00
Arthur Barraux 09d78f48e9 Merge remote-tracking branch 'gitea/lisp'
Build project / build (push) Successful in 1m3s
2025-10-06 11:37:39 +02:00
arthur d9aab06c1c Downgrade upload version to 3
CMake Build and Deploy / build (push) Failing after 2m34s
2025-09-24 11:07:22 +02:00
arthur ec0eba849a Update .gitea/workflows/build.yml
CMake Build and Deploy / build (push) Failing after 1m58s
2025-09-24 08:33:08 +02:00
arthur 2ca64fae41 add build.yml
CMake Build and Deploy / build (push) Has been cancelled
2025-09-24 08:32:22 +02:00
75 changed files with 1302 additions and 25647 deletions
+10 -4
View File
@@ -1,12 +1,12 @@
name: Build and Deploy Docs
name: Build project
on:
push:
branches: ["lisp"]
branches: ["main"]
jobs:
build:
runs-on: home-1
runs-on: giorgio-runner
steps:
- name: Checkout code
@@ -26,4 +26,10 @@ jobs:
run: meson compile -C build
- name: Run tests
run: meson test -C build --print-errorlogs || true
run: ctest --test-dir build || true
- name: Upload artifact
uses: actions/upload-artifact@v3
with:
name: beluga
path: build/beluga
+16 -10
View File
@@ -1,26 +1,32 @@
# Beluga
Beluga is a project of CLI text editor that will fit perfectly with your azerty keyboard.
Beluga is a project of CLI text editor that uses lisp as configuration language.
## Requirements
You will only need **cmake** and **clang** to compile the editor.
You will only need **meson** and a **C compiler** to compile the editor.
## Installation
### From source
Here is the installation line for development version:
```git clone --recurse-submodules https://github.com/le-cocotier/beluga.git ~/.beluga && cd ~/.beluga && mkdir build && cd build && cmake ../ && make beluga```
```git clone https://git.giorgio-nas.fr/arthur/beluga.git && cd beluga && meson setup build && meson compile -C build```
The executable file will be in `bin/beluga`. Feel free to add it to your path.
The executable file will be `build/beluga`. Feel free to add it to your path.
You can either run `make all` or `make doc_doxygen` if you're interested by the doxygen documentation.
### From installation script ( prefered )
Just clone the repo and execute the script `install.sh`. It will automatically add beluga to your path.
## Getting start
To open an existing file just type :
```beluga path_to_my_file```
```./build/beluga path_to_my_file```
The only keybinds that you will need will be :
- Ctrl-Q : leave the editor
- Ctrl-S : Save a file
Here is some few command that you will need :
| keybind | command |
|---------------|------------------|
| Ctrl-x Ctrl-c | leave the editor |
| Ctrl-x Ctrl-s | Save a file |
| Ctrl-x f | open file |
+4 -4
View File
@@ -9,12 +9,12 @@
#----------------------------------------------------------##
#=--------------------------------------------------------------##
+--------------------------+@#-%*-----------------------------------#*
+--------------------------%@@@@#-------------------------------------** BELUGA - VERSION 1.1
+--------------------------%@@@@#-------------------------------------** BELUGA - VERSION 2.2.1
*-=-------------------------#@@*---------------------------------------=%
%*#==--------------------------------------------------------------------+# ----- KEY-BINDS -----
*%%=-=--------------------------------------------------------------------=# CTRL-q leave
%=--------------------------------------------------------------------------#* CTRL-s save
%-----------------------------------------------------------------------------** CTRL-o open-file
*%%=-=--------------------------------------------------------------------=# CTRL-x CTRL-c leave
%=--------------------------------------------------------------------------#* CTRL-x CTRL-s save
%-----------------------------------------------------------------------------** CTRL-x f open-file
*+--=---===----=---------------=*-----------------------------------------------**
#--=## *#%#*+==----==+**+----------------------= ***=---------------------%
*%**=-----------==== ==---------------------------------=+#+-----------------=#
+65 -15
View File
@@ -3,6 +3,11 @@
(define TAB-LENGTH 4)
(define QUIT-TIMES 1)
;; PACKAGES
;; First git clone it
;; (add-package "smart_delimiters")
;; FUNCTIONS
(define editor-delete-next-char (lambda () (
@@ -13,22 +18,67 @@
)
;; KEY MAPPING
(define (char-between ch lo hi)
(if (char>=? ch lo)
(char<=? ch hi)
#f))
(map-key "CTRL-q" editor-quit)
(map-key "CTRL-s" editor-save)
(map-key "ARROW-UP" '(move-cursor "up"))
(map-key "ARROW-DOWN" '(move-cursor "down"))
(map-key "ARROW-RIGHT" '(move-cursor "right"))
(map-key "ARROW-LEFT" '(move-cursor "left"))
(map-key "ENTER" editor-insert-new-line)
(map-key "CTRL-a" move-cursor-beg-line)
(map-key "CTRL-e" move-cursor-end-line)
(map-key "BACKSPACE" editor-delete-previous-char)
(map-key "DEL" editor-delete-next-char)
(map-key "PAGE-UP" move-cursor-page-up)
(map-key "PAGE-DOWN" move-cursor-page-down)
(map-key "CTRL-o" editor-open-file)
(define (alphanumericp ch)
(if ch
(if (char-between ch #\a #\z)
#t
(if (char-between ch #\A #\Z)
#t
(if (char-between ch #\0 #\9)
#t
#f)))
#f))
(define (word-char-p ch)
(if (alphanumericp ch)
#t
#f))
(define editor-move-to-end-of-word (lambda () (
(if (word-char-p (editor-read-char))
((move-cursor "right")
(editor-move-to-end-of-word))
))
))
(define enter-and-tab
(lambda ()
(editor-insert-new-line)
(let ((is-in (move-cursor "up")))
(do ((ch (editor-read-char) (editor-read-char)))
((and (not (char=? ch #\space)) is-in) #f)
(move-cursor "down")
(editor-insert-char " ")
(set! is-in (move-cursor "up")))
(move-cursor "down"))))
(add-prefix "user")
(map-key "CTRL-x" '(editor-set-prefix "user") "no-prefix")
(map-key "CTRL-g" '(editor-set-prefix "no-prefix") "user")
(map-key "CTRL-c" editor-quit "user")
(map-key "CTRL-s" editor-save "user")
(map-key "ARROW-UP" '(move-cursor "up") "no-prefix")
(map-key "ARROW-DOWN" '(move-cursor "down") "no-prefix")
(map-key "ARROW-RIGHT" '(move-cursor "right") "no-prefix")
(map-key "ARROW-LEFT" '(move-cursor "left") "no-prefix")
(map-key "ENTER" enter-and-tab "no-prefix")
(map-key "CTRL-a" move-cursor-beg-line "no-prefix")
(map-key "CTRL-e" move-cursor-end-line "no-prefix")
(map-key "BACKSPACE" editor-delete-previous-char "no-prefix")
(map-key "DEL" editor-delete-next-char "no-prefix")
(map-key "PAGE-UP" move-cursor-page-up "no-prefix")
(map-key "PAGE-DOWN" move-cursor-page-down "no-prefix")
(map-key "f" editor-open-file "user")
(map-key "TAB" editor-insert-tab "no-prefix")
(map-key "CTRL-k" editor-del-row "no-prefix")
(map-key "CTRL-s" editor-find "no-prefix")
(map-key "CTRL-r" editor-move-to-end-of-word "no-prefix")
+17 -1
View File
@@ -1,7 +1,7 @@
#ifndef BUILTINS_H_
#define BUILTINS_H_
#include "../lisp-interpreter/dist/lisp.h"
#include "lisp.h"
Lisp moveCursor(Lisp args, LispError *e, LispContext ctx);
@@ -19,6 +19,8 @@ Lisp moveCursorBeginLine(Lisp args, LispError *e, LispContext ctx);
Lisp moveCursorEndLine(Lisp args, LispError *e, LispContext ctx);
Lisp l_editorInserTab(Lisp args, LispError *e, LispContext ctx);
Lisp deletePreviousChar(Lisp args, LispError *e, LispContext ctx);
Lisp editorMoveCursorPageUp(Lisp args, LispError* e, LispContext ctx);
@@ -29,4 +31,18 @@ Lisp editorOpenFile(Lisp args, LispError *e, LispContext ctx);
Lisp editorPrintC(Lisp args, LispError *e, LispContext ctx);
Lisp addPackage(Lisp args, LispError *e, LispContext ctx);
Lisp editorDelRow_L(Lisp args, LispError *e, LispContext ctx);
Lisp editorFind_L(Lisp args, LispError *e, LispContext ctx);
Lisp editorReadChar_L(Lisp args, LispError *e, LispContext ctx);
Lisp editorSetPrefix(Lisp args, LispError *e, LispContext ctx);
Lisp editorPrefix(Lisp args, LispError *e, LispContext ctx);
void free_structs(void);
#endif
+12 -1
View File
@@ -5,7 +5,7 @@
#include <termios.h>
#include <time.h>
#include "../lisp-interpreter/dist/lisp.h"
#include "lisp.h"
/**
* \struct erow
@@ -31,8 +31,14 @@ struct const_t {
int QUIT_TIMES;
};
struct prefix_t {
char prefix_name[64];
int prefix_id;
};
struct keyBind_t {
char *key_sequence;
int prefix_id;
Lisp command;
};
@@ -53,6 +59,7 @@ struct editorConfig {
int dirty;
char *filename;
enum editorStatus_e state;
int prefix_state;
char status_msg[80];
time_t status_msg_time;
struct termios orig_termios; /**< Terminal communication interface */
@@ -60,6 +67,7 @@ struct editorConfig {
struct const_t constantes;
int quit_times_buffer;
char *init_file_path;
FILE *fd_init_file;
Lisp env;
LispContext ctx; /** Lisp context */
@@ -68,6 +76,9 @@ struct editorConfig {
struct keyBind_t* key_binds;
int number_of_keybinds;
struct prefix_t* prefix;
int number_of_prefix;
};
+2
View File
@@ -17,4 +17,6 @@ void editorOpen(char *filename);
void editorSave();
void editorFind();
#endif // FILE_IO_H_
+2 -2
View File
@@ -20,11 +20,11 @@
// END \x1b[4~ || <esc>[8~ || <esc>[F || <esc>OF
// DELETE \x1b[3~
char *editorPrompt(char *prompt);
char *editorPrompt(char *prompt, char * PlaceHolder, char bPathMode);
char *key_to_string(int key);
void editorMoveCursor(int key);
int editorMoveCursor(int key);
int executeKeyBind(char *key_sequence);
+16 -13
View File
@@ -1861,8 +1861,8 @@ static Lisp parse_symbol_(Lexer* lex, LispContext ctx)
char scratch[LISP_IDENTIFIER_MAX];
size_t length = lexer_copy_token(lex, 0, LISP_IDENTIFIER_MAX, scratch);
// always convert symbols to uppercase
for (int i = 0; i < length; ++i)
scratch[i] = toupper(scratch[i]);
// for (int i = 0; i < length; ++i)
// scratch[i] = toupper(scratch[i]);
return symbol_intern_(ctx.p->symbols, scratch, length, ctx);
}
@@ -2075,8 +2075,10 @@ static Lisp parse(Lexer* lex, LispError* out_error, LispContext ctx)
result = lisp_cons(get_sym(SYM_BEGIN, ctx), lisp_list_reverse(result), ctx);
}
if (out_error) *out_error = error;
if (out_error)
*out_error = error;
return result;
}
Lisp lisp_read(const char *program, LispError* out_error, LispContext ctx)
@@ -2122,6 +2124,7 @@ void* fread_all_(FILE* file, size_t* out_size) {
return NULL;
}
data = new_data;
memset(data + *out_size, 0, cap - *out_size);
}
size_t read = fread(data + *out_size, 1, BLOCK_SIZE, file);
@@ -3183,17 +3186,17 @@ LispContext lisp_init(void)
ctx.p->macros = lisp_make_table(ctx);
Lisp* c = ctx.p->symbol_cache;
c[SYM_IF] = lisp_make_symbol("IF", ctx);
c[SYM_BEGIN] = lisp_make_symbol("BEGIN", ctx);
c[SYM_QUOTE] = lisp_make_symbol("QUOTE", ctx);
c[SYM_QUASI_QUOTE] = lisp_make_symbol("QUASIQUOTE", ctx);
c[SYM_UNQUOTE] = lisp_make_symbol("UNQUOTE", ctx);
c[SYM_UNQUOTE_SPLICE] = lisp_make_symbol("UNQUOTESPLICE", ctx);
c[SYM_DEFINE] = lisp_make_symbol("_DEF", ctx);
c[SYM_DEFINE_MACRO] = lisp_make_symbol("DEFINE-MACRO", ctx);
c[SYM_SET] = lisp_make_symbol("_SET!", ctx);
c[SYM_IF] = lisp_make_symbol("if", ctx);
c[SYM_BEGIN] = lisp_make_symbol("begin", ctx);
c[SYM_QUOTE] = lisp_make_symbol("quote", ctx);
c[SYM_QUASI_QUOTE] = lisp_make_symbol("quasiquote", ctx);
c[SYM_UNQUOTE] = lisp_make_symbol("unquote", ctx);
c[SYM_UNQUOTE_SPLICE] = lisp_make_symbol("unquotesplice", ctx);
c[SYM_DEFINE] = lisp_make_symbol("_def", ctx);
c[SYM_DEFINE_MACRO] = lisp_make_symbol("define-macro", ctx);
c[SYM_SET] = lisp_make_symbol("_set!", ctx);
c[SYM_LAMBDA] = lisp_make_symbol("/\\_", ctx);
c[SYM_CONS] = lisp_make_symbol("CONS", ctx);
c[SYM_CONS] = lisp_make_symbol("cons", ctx);
return ctx;
}
@@ -36,7 +36,7 @@ static const char* lib_0_sequences_src_ =
(if (pair? args) \n\
(if (pair? (cdr args)) \n\
(if (pair? (cdr (cdr args))) \n\
`(/\\_ ,(car args) ,(cons 'BEGIN (cdr args))) \n\
`(/\\_ ,(car args) ,(cons 'begin (cdr args))) \n\
`(/\\_ ,(car args) ,(car (cdr args)))) \n\
(syntax-error \"lambda missing body expressions: (lambda (args) body)\")) \n\
(syntax-error \"lambda missing argument: (lambda (args) body)\")))) \n\
@@ -44,18 +44,18 @@ static const char* lib_0_sequences_src_ =
(define-macro set! (lambda (var x) \n\
(begin \n\
(if (not (symbol? var)) (syntax-error \"set! not a variable\")) \n\
`(_SET! ,var ,x)))) \n\
`(_set! ,var ,x)))) \n\
\n\
(define-macro define \n\
(lambda (var . exprs) \n\
(if (symbol? var) \n\
(if (pair? (cdr exprs)) \n\
(syntax-error \"define: (define var x)\") \n\
`(_DEF ,var ,(car exprs))) \n\
`(_def ,var ,(car exprs))) \n\
(if (pair? var) \n\
`(_DEF ,(car var) \n\
(LAMBDA ,(cdr var) \n\
,(if (null? (cdr exprs)) (car exprs) (cons 'BEGIN exprs)))) \n\
`(_def ,(car var) \n\
(lambda ,(cdr var) \n\
,(if (null? (cdr exprs)) (car exprs) (cons 'begin exprs)))) \n\
(syntax-error \"define: not a symbol\") )))) \n\
\n\
(define (first x) (car x)) \n\
@@ -98,13 +98,13 @@ static const char* lib_0_sequences_src_ =
(define (_expand-shorthand-body path) \n\
(if (null? path) (cons 'pair '()) \n\
(list (if (char=? (car path) #\\A) \n\
(cons 'CAR (_expand-shorthand-body (cdr path))))))) \n\
(cons 'car (_expand-shorthand-body (cdr path))))))) \n\
\n\
(define (_expand-shorthand text) \n\
(cons 'DEFINE (cons (list (string->symbol (string-append \"C\" text \"R\")) 'pair) \n\
(cons 'define (cons (list (string->symbol (string-append \"C\" text \"R\")) 'pair) \n\
(_expand-shorthand-body (string->list text))))) \n\
\n\
(define-macro _shorthand-accessors (lambda args (cons 'BEGIN (map1 _expand-shorthand args)))) \n\
(define-macro _shorthand-accessors (lambda args (cons 'begin (map1 _expand-shorthand args)))) \n\
\n\
(define (vector . args) (list->vector args)) \n\
\n\
@@ -124,14 +124,14 @@ static const char* lib_0_sequences_src_ =
static const char* lib_1_forms_src_ =
"(define (_make-lambda args body) \n\
(list 'LAMBDA args (if (null? (cdr body)) (car body) (cons 'BEGIN body)))) \n\
(list 'lambda args (if (null? (cdr body)) (car body) (cons 'begin body)))) \n\
\n\
\n\
; (LET <name> ((<var0> <expr0>) ... (<varN> <expr1>)) <body0> ... <bodyN>) \n\
; => ((LAMBDA (<var0> ... <varN>) (BEGIN <body0> ... <bodyN>)) <expr0> ... <expr1>) \n\
; (let <name> ((<var0> <expr0>) ... (<varN> <expr1>)) <body0> ... <bodyN>) \n\
; => ((lambda (<var0> ... <varN>) (begin <body0> ... <bodyN>)) <expr0> ... <expr1>) \n\
; => named \n\
; ((lambda () \n\
; (define <name> (LAMBDA (<var0> ... <varN>) (BEGIN <body0> ... <bodyN>))) \n\
; (define <name> (lambda (<var0> ... <varN>) (begin <body0> ... <bodyN>))) \n\
; (<name> <expr0> ... <exprN>))) \n\
\n\
(define (_check-binding-list bindings) \n\
@@ -145,7 +145,7 @@ static const char* lib_1_forms_src_ =
(define initial-args (map1 (lambda (entry) (second entry)) bindings)) \n\
(if (null? var) \n\
(cons body-func initial-args) \n\
(list (_make-lambda '() (list (list 'DEFINE var body-func) (cons var initial-args)))))) \n\
(list (_make-lambda '() (list (list 'define var body-func) (cons var initial-args)))))) \n\
\n\
(define-macro let (lambda args \n\
(if (pair? (first args)) \n\
@@ -153,8 +153,8 @@ static const char* lib_1_forms_src_ =
(_let->combination (first args) (second args) (cdr (cdr args)))))) \n\
\n\
(define (_let*-helper bindings body) \n\
(if (null? bindings) (if (null? (cdr body)) (car body) (cons 'BEGIN body)) \n\
(list 'LET (list (car bindings)) (_let*-helper (cdr bindings) body)))) \n\
(if (null? bindings) (if (null? (cdr body)) (car body) (cons 'begin body)) \n\
(list 'let (list (car bindings)) (_let*-helper (cdr bindings) body)))) \n\
\n\
(define-macro let* (lambda (bindings . body) \n\
(_check-binding-list bindings) \n\
@@ -163,17 +163,17 @@ static const char* lib_1_forms_src_ =
(define-macro letrec (lambda (bindings . body) \n\
(_check-binding-list bindings) \n\
(cons (_make-lambda (map1 (lambda (entry) (first entry)) bindings) \n\
(append (map1 (lambda (entry) (list 'SET! (first entry) (second entry))) \n\
(append (map1 (lambda (entry) (list 'set! (first entry) (second entry))) \n\
bindings) body)) \n\
(map1 (lambda (entry) '()) bindings)))) \n\
\n\
\n\
; (COND (<pred0> <expr0>) \n\
; (cond (<pred0> <expr0>) \n\
; (<pred1> <expr1>) \n\
; ... \n\
; (else <expr-1>)) \n\
; => \n\
; (IF <pred0> <expr0> \n\
; (if <pred0> <expr0> \n\
; (if <pred1> <expr1> \n\
; .... \n\
; (if <predN> <exprN> <expr-1>)) ... ) \n\
@@ -187,11 +187,11 @@ static const char* lib_1_forms_src_ =
\n\
(define (_cond-helper clauses) \n\
(if (null? clauses) '() \n\
(if (eq? (car (car clauses)) 'ELSE) \n\
(cons 'BEGIN (cdr (car clauses))) \n\
(list 'IF \n\
(if (eq? (car (car clauses)) 'else) \n\
(cons 'begin (cdr (car clauses))) \n\
(list 'if \n\
(car (car clauses)) \n\
(cons 'BEGIN (cdr (car clauses))) \n\
(cons 'begin (cdr (car clauses))) \n\
(_cond-helper (cdr clauses)))))) \n\
\n\
(define-macro cond (lambda clauses \n\
@@ -206,26 +206,26 @@ static const char* lib_2_forms_src_ =
(cond ((null? preds) #t) \n\
((null? (cdr preds)) (car preds)) \n\
(else \n\
`(IF ,(car preds) ,(_and-helper (cdr preds)) #f)))) \n\
`(if ,(car preds) ,(_and-helper (cdr preds)) #f)))) \n\
(define-macro and (lambda preds (_and-helper preds))) \n\
\n\
(define (_or-helper preds var) \n\
(cond ((null? preds) #f) \n\
((null? (cdr preds)) (car preds)) \n\
(else \n\
`(BEGIN (SET! ,var ,(car preds)) \n\
(IF ,var ,var ,(_or-helper (cdr preds) var)))))) \n\
`(begin (set! ,var ,(car preds)) \n\
(if ,var ,var ,(_or-helper (cdr preds) var)))))) \n\
\n\
(define-macro or (lambda preds \n\
(let ((var (gensym))) \n\
`(LET ((,var '())) ,(_or-helper preds var))))) \n\
`(let ((,var '())) ,(_or-helper preds var))))) \n\
\n\
(define-macro case (lambda (key . clauses) \n\
(let ((expr (gensym))) \n\
`(LET ((,expr ,key)) \n\
,(cons 'COND (map1 (lambda (entry) \n\
`(let ((,expr ,key)) \n\
,(cons 'cond (map1 (lambda (entry) \n\
(cons (if (pair? (car entry)) \n\
`(MEMV ,expr (quote ,(car entry))) \n\
`(memv ,expr (quote ,(car entry))) \n\
(car entry)) \n\
(cdr entry))) clauses)))))) \n\
\n\
@@ -234,23 +234,24 @@ static const char* lib_2_forms_src_ =
`(begin (set! ,l (cons ,v ,l)) ,l))) \n\
\n\
; (DO ((<var0> <init0> <step0>) ...) (<test> <result>) <body>) \n\
(define-macro do \n\
(lambda (vars loop-check . loops) \n\
(let ( (names '()) (inits '()) (steps '()) (f (gensym)) ) \n\
(for-each1 (lambda (var) \n\
(push (car var) names) \n\
(set! var (cdr var)) \n\
(push (car var) inits) \n\
(set! var (cdr var)) \n\
(push (car var) steps)) vars) \n\
`((LAMBDA () \n\
(DEFINE ,f (LAMBDA ,names \n\
(IF ,(car loop-check) \n\
,(if (pair? (cdr loop-check)) (car (cdr loop-check)) '()) \n\
,(cons 'BEGIN (append loops (list (cons f steps)))) ))) \n\
,(cons f inits) \n\
)) ))) \n\
\n\
(define-macro do \n\
(lambda (vars loop-check . loops) \n\
(let ( (names '()) (inits '()) (steps '()) (f (gensym)) ) \n\
(for-each1 (lambda (var-spec) \n\
(push (car var-spec) names) \n\
(push (car (cdr var-spec)) inits) \n\
(if (pair? (cdr (cdr var-spec))) \n\
(push (car (cdr (cdr var-spec))) steps) \n\
(push (car var-spec) steps))) vars) \n\
`((lambda () \n\
(define ,f (lambda ,names \n\
(if ,(car loop-check) \n\
,(if (pair? (cdr loop-check)) (car (cdr loop-check)) '()) \n\
,(cons 'begin (append loops (list (cons f steps)))) ))) \n\
,(cons f inits) \n\
)) ))) \n\
\n\
(define-macro dotimes \n\
(lambda (form body) \n\
(apply (lambda (i n . result) \n\
@@ -262,18 +263,18 @@ static const char* lib_2_forms_src_ =
(define-macro swap! \n\
(lambda (x y) \n\
(let ((temp (gensym))) \n\
`(LET ((,temp ,x)) \n\
(SET! ,temp ,x) \n\
(SET! ,x ,y) \n\
(SET! ,y ,temp))))) \n\
`(let ((,temp ,x)) \n\
(set! ,temp ,x) \n\
(set! ,x ,y) \n\
(set! ,y ,temp))))) \n\
\n\
(define-macro inc! ; CL incf \n\
(lambda (x) \n\
`(SET! ,x (+ ,x 1)))) \n\
`(set! ,x (+ ,x 1)))) \n\
\n\
(define-macro dec! ; CL decf \n\
(lambda (x) \n\
`(SET! ,x (- ,x 1))))";
`(set! ,x (- ,x 1))))";
static const char* lib_3_math_src_ =
"(define (number? x) (real? x)) \n\
@@ -445,7 +446,7 @@ static const char* lib_4_sequences_src_ =
static const char* lib_5_streams_src_ =
"(define-macro delay (lambda (expr) \n\
`(make-promise ,(cons 'LAMBDA \n\
`(make-promise ,(cons 'lambda \n\
(cons '() \n\
(cons expr '())))))) \n\
\n\
@@ -1926,182 +1927,178 @@ static Lisp sch_is_cont(Lisp args, LispError* e, LispContext ctx)
static const LispFuncDef lib_cfunc_defs[] = {
{ "ERROR", sch_error },
{ "SYNTAX-ERROR", sch_syntax_error },
{ "error", sch_error },
{ "syntax-error", sch_syntax_error },
// Output Procedures https://www.gnu.org/software/mit-scheme/documentation/mit-scheme-ref/Output-Procedures.html
{ "_WRITE", sch_write },
{ "_DISPLAY", sch_display },
{ "_WRITE-CHAR", sch_write_char },
{ "_FLUSH-OUTPUT-PORT", sch_flush },
{ "_READ", sch_read },
{ "INPUT-PORT?", sch_is_port_in },
{ "OUTPUT-PORT?", sch_is_port_out },
{ "OPEN-INPUT-FILE", sch_open_input },
{ "OPEN-OUTPUT-FILE", sch_open_output },
{ "CLOSE-INPUT-PORT", sch_port_close },
{ "CLOSE-OUTPUT-PORT", sch_port_close },
{ "EOF-OBJECT?", sch_is_eof },
// Output Procedures
{ "_write", sch_write },
{ "_display", sch_display },
{ "_write-char", sch_write_char },
{ "_flush-output-port", sch_flush },
{ "_read", sch_read },
{ "input-port?", sch_is_port_in },
{ "output-port?", sch_is_port_out },
{ "open-input-file", sch_open_input },
{ "open-output-file", sch_open_output },
{ "close-input-port", sch_port_close },
{ "close-output-port", sch_port_close },
{ "eof-object?", sch_is_eof },
// Universal Time https://www.gnu.org/software/mit-scheme/documentation/mit-scheme-ref/Universal-Time.html
{ "GET-UNIVERSAL-TIME", sch_univeral_time },
{ "PRINT-GC-STATISTICS", sch_print_gc_stats },
// Universal Time
{ "get-universal-time", sch_univeral_time },
{ "print-gc-statistics", sch_print_gc_stats },
{ "MACROEXPAND", sch_macroexpand },
{ "macroexpand", sch_macroexpand },
// Equivalence Predicates https://www.gnu.org/software/mit-scheme/documentation/mit-scheme-ref/Equivalence-Predicates.html
{ "EQ?", sch_exact_eq },
{ "EQV?", sch_equal },
{ "EQUAL?", sch_equal_r },
// Equivalence Predicates
{ "eq?", sch_exact_eq },
{ "eqv?", sch_equal },
{ "equal?", sch_equal_r },
// Booleans https://www.gnu.org/software/mit-scheme/documentation/mit-scheme-ref/Booleans.html
{ "BOOLEAN?", sch_is_boolean },
{ "NOT", sch_not },
// Booleans
{ "boolean?", sch_is_boolean },
{ "not", sch_not },
// PAIRS
{ "CONS", sch_cons },
{ "CAR", sch_car },
{ "CDR", sch_cdr },
{ "SET-CAR!", sch_set_car },
{ "SET-CDR!", sch_set_cdr },
{ "NULL?", sch_is_null },
{ "PAIR?", sch_is_pair },
{ "cons", sch_cons },
{ "car", sch_car },
{ "cdr", sch_cdr },
{ "set-car!", sch_set_car },
{ "set-cdr!", sch_set_cdr },
{ "null?", sch_is_null },
{ "pair?", sch_is_pair },
// Lists https://groups.csail.mit.edu/mac/ftpdir/scheme-7.4/doc-html/scheme_8.html
{ "LIST", sch_list },
{ "LIST?", sch_is_list },
{ "MAKE-LIST", sch_make_list },
{ "LIST-COPY", sch_list_copy },
{ "LENGTH", sch_length },
{ "APPEND", sch_append },
{ "APPEND-REVERSE!", sch_append_reverse },
{ "LIST-REF", sch_list_ref },
{ "NTHCDR", sch_list_advance },
// Lists
{ "list", sch_list },
{ "list?", sch_is_list },
{ "make-list", sch_make_list },
{ "list-copy", sch_list_copy },
{ "length", sch_length },
{ "append", sch_append },
{ "append-reverse!", sch_append_reverse },
{ "list-ref", sch_list_ref },
{ "nthcdr", sch_list_advance },
// Vectors https://groups.csail.mit.edu/mac/ftpdir/scheme-7.4/doc-html/scheme_9.html#SEC82
{ "VECTOR?", sch_is_vector },
{ "MAKE-VECTOR", sch_make_vector },
{ "VECTOR-GROW", sch_vector_grow },
{ "VECTOR-LENGTH", sch_vector_length },
{ "VECTOR-SET!", sch_vector_set },
{ "VECTOR-SWAP!", sch_vector_swap },
{ "VECTOR-REF", sch_vector_ref },
{ "VECTOR-FILL!", sch_vector_fill },
{ "VECTOR-ASSQ", sch_vector_assq },
{ "SUBVECTOR", sch_subvector },
{ "LIST->VECTOR", sch_list_to_vector },
{ "VECTOR->LIST", sch_vector_to_list },
// Vectors
{ "vector?", sch_is_vector },
{ "make-vector", sch_make_vector },
{ "vector-grow", sch_vector_grow },
{ "vector-length", sch_vector_length },
{ "vector-set!", sch_vector_set },
{ "vector-swap!", sch_vector_swap },
{ "vector-ref", sch_vector_ref },
{ "vector-fill!", sch_vector_fill },
{ "vector-assq", sch_vector_assq },
{ "subvector", sch_subvector },
{ "list->vector", sch_list_to_vector },
{ "vector->list", sch_vector_to_list },
// Strings https://groups.csail.mit.edu/mac/ftpdir/scheme-7.4/doc-html/scheme_7.html#SEC61
{ "STRING?", sch_is_string },
{ "MAKE-STRING", sch_make_string },
{ "STRING=?", sch_equal_r },
{ "STRING<?", sch_string_less },
{ "SUBSTRING", sch_substring },
{ "STRING-NULL?", sch_string_is_null },
{ "STRING-LENGTH", sch_string_length },
{ "STRING-REF", sch_string_ref },
{ "STRING-SET!", sch_string_set },
{ "STRING-UPCASE", sch_string_upcase },
{ "STRING-DOWNCASE", sch_string_downcase },
{ "STRING-APPEND", sch_string_append },
{ "STRING->LIST", sch_string_to_list },
{ "LIST->STRING", sch_list_to_string },
{ "STRING->NUMBER", sch_string_to_number },
{ "NUMBER->STRING", sch_number_to_string },
// Strings
{ "string?", sch_is_string },
{ "make-string", sch_make_string },
{ "string=?", sch_equal_r },
{ "string<?", sch_string_less },
{ "substring", sch_substring },
{ "string-null?", sch_string_is_null },
{ "string-length", sch_string_length },
{ "string-ref", sch_string_ref },
{ "string-set!", sch_string_set },
{ "string-upcase", sch_string_upcase },
{ "string-downcase", sch_string_downcase },
{ "string-append", sch_string_append },
{ "string->list", sch_string_to_list },
{ "list->string", sch_list_to_string },
{ "string->number", sch_string_to_number },
{ "number->string", sch_number_to_string },
// Characters https://www.gnu.org/software/mit-scheme/documentation/mit-scheme-ref/Characters.html#Characters
{ "CHAR?", sch_is_char },
{ "CHAR=?", sch_equals },
{ "CHAR<?", sch_char_less },
// Characters
{ "char?", sch_is_char },
{ "char=?", sch_equals },
{ "char<?", sch_char_less },
{ "CHAR-UPCASE", sch_char_upcase },
{ "CHAR-DOWNCASE", sch_char_downcase },
{ "CHAR-WHITESPACE?", sch_char_is_white },
{ "CHAR-ALPHANUMERIC?", sch_char_is_alphanum },
{ "CHAR-ALPHABETIC?", sch_char_is_alpha },
{ "CHAR-NUMERIC?", sch_char_is_number },
{ "CHAR->INTEGER", sch_char_to_int },
{ "char-upcase", sch_char_upcase },
{ "char-downcase", sch_char_downcase },
{ "char-whitespace?", sch_char_is_white },
{ "char-alphanumeric?", sch_char_is_alphanum },
{ "char-alphabetic?", sch_char_is_alpha },
{ "char-numeric?", sch_char_is_number },
{ "char->integer", sch_char_to_int },
// Association Lists https://www.gnu.org/software/mit-scheme/documentation/mit-scheme-ref/Association-Lists.html
// Numerical operations https://www.gnu.org/software/mit-scheme/documentation/mit-scheme-ref/Numerical-operations.html
// Numerical operations
{ "=", sch_equals },
{ "+", sch_add },
{ "-", sch_sub },
{ "*", sch_mult },
{ "/", sch_divide },
{ "<", sch_less },
{ "INTEGER?", sch_is_int },
{ "EVEN?", sch_is_even },
{ "REAL?", sch_is_real },
{ "EXP", sch_exp },
{ "EXPT", sch_power },
{ "LOG", sch_log },
{ "SIN", sch_sin },
{ "COS", sch_cos },
{ "TAN", sch_tan },
{ "ATAN", sch_atan },
{ "SQRT", sch_sqrt },
{ "ROUND", sch_round },
{ "FLOOR", sch_floor },
{ "CEILING", sch_ceiling },
{ "QUOTIENT", sch_quotient },
{ "REMAINDER", sch_remainder },
{ "MODULO", sch_modulo },
{ "ABS", sch_abs },
{ "MAGNITUDE", sch_abs },
{ "EXACT?", sch_is_int },
{ "EXACT->INEXACT", sch_to_inexact },
{ "INEXACT->EXACT", sch_to_exact },
{ "integer?", sch_is_int },
{ "even?", sch_is_even },
{ "real?", sch_is_real },
{ "exp", sch_exp },
{ "expt", sch_power },
{ "log", sch_log },
{ "sin", sch_sin },
{ "cos", sch_cos },
{ "tan", sch_tan },
{ "atan", sch_atan },
{ "sqrt", sch_sqrt },
{ "round", sch_round },
{ "floor", sch_floor },
{ "ceiling", sch_ceiling },
{ "quotient", sch_quotient },
{ "remainder", sch_remainder },
{ "modulo", sch_modulo },
{ "abs", sch_abs },
{ "magnitude", sch_abs },
{ "exact?", sch_is_int },
{ "exact->inexact", sch_to_inexact },
{ "inexact->exact", sch_to_exact },
// Symbols https://www.gnu.org/software/mit-scheme/documentation/mit-scheme-ref/Symbols.html
{ "SYMBOL?", sch_is_symbol },
{ "SYMBOL<?", sch_symbol_less },
{ "STRING->SYMBOL", sch_string_to_symbol },
{ "SYMBOL->STRING", sch_symbol_to_string },
{ "GENERATE-UNINTERNED-SYMBOL", sch_gensym },
{ "GENSYM", sch_gensym },
// Symbols
{ "symbol?", sch_is_symbol },
{ "symbol<?", sch_symbol_less },
{ "string->symbol", sch_string_to_symbol },
{ "symbol->string", sch_symbol_to_string },
{ "generate-uninterned-symbol", sch_gensym },
{ "gensym", sch_gensym },
// Environments https://groups.csail.mit.edu/mac/ftpdir/scheme-7.4/doc-html/scheme_14.html
{ "EVAL", sch_eval },
{ "SCHEME-REPORT-ENVIRONMENT", sch_system_env },
{ "INTERACTION-ENVIRONMENT", sch_user_env },
// { "THE-ENVIRONMENT", sch_current_env },
// Environments
{ "eval", sch_eval },
{ "scheme-report-environment", sch_system_env },
{ "interaction-environment", sch_user_env },
// Hash Tables https://www.gnu.org/software/mit-scheme/documentation/mit-scheme-ref/Basic-Hash-Table-Operations.html#Basic-Hash-Table-Operations
{ "HASH-TABLE?", sch_is_table },
{ "MAKE-HASH-TABLE", sch_table_make },
{ "HASH-TABLE-SET!", sch_table_set },
{ "HASH-TABLE-REF", sch_table_get },
{ "HASH-TABLE-SIZE", sch_table_size },
{ "HASH-TABLE->ALIST", sch_table_to_alist },
// Hash Tables
{ "hash-table?", sch_is_table },
{ "make-hash-table", sch_table_make },
{ "hash-table-set!", sch_table_set },
{ "hash-table-ref", sch_table_get },
{ "hash-table-size", sch_table_size },
{ "hash-table->alist", sch_table_to_alist },
{ "PROMISE?", sch_is_promise },
{ "MAKE-PROMISE", sch_make_promise },
{ "_PROMISE-PROCEDURE", sch_promise_proc },
{ "_PROMISE-STORE!", sch_promise_store },
{ "PROMISE-VALUE", sch_promise_val },
{ "PROMISE-FORCED?", sch_promise_forced },
{ "promise?", sch_is_promise },
{ "make-promise", sch_make_promise },
{ "_promise-procedure", sch_promise_proc },
{ "_promise-store!", sch_promise_store },
{ "promise-value", sch_promise_val },
{ "promise-forced?", sch_promise_forced },
// Procedures https://www.gnu.org/software/mit-scheme/documentation/mit-scheme-ref/Procedure-Operations.html#Procedure-Operations
{ "APPLY", sch_apply },
{ "COMPILED-PROCEDURE?", sch_is_func },
{ "COMPOUND-PROCEDURE?", sch_is_lambda },
{ "PROCEDURE-ENVIRONMENT", sch_lambda_env },
// TOOD: Almost standard
{ "PROCEDURE-BODY", sch_lambda_body },
{ "CALL/CC", sch_call_cc },
{ "CONTINUATION?", sch_is_cont },
// Procedures
{ "apply", sch_apply },
{ "compiled-procedure?", sch_is_func },
{ "compound-procedure?", sch_is_lambda },
{ "procedure-environment", sch_lambda_env },
{ "procedure-body", sch_lambda_body },
{ "call/cc", sch_call_cc },
{ "continuation?", sch_is_cont },
// Random Numbers https://www.gnu.org/software/mit-scheme/documentation/mit-scheme-ref/Random-Numbers.html
{ "RANDOM", sch_pseudo_rand },
{ "RANDOM-SEED!", sch_pseudo_seed },
// Random Numbers
{ "random", sch_pseudo_rand },
{ "random-seed!", sch_pseudo_seed },
// Garbage Collection https://www.gnu.org/software/mit-scheme/documentation/mit-scheme-user/Garbage-Collection.html
{ "GC-FLIP", sch_gc_flip },
// Garbage Collection
{ "gc-flip", sch_gc_flip },
{ NULL, NULL }
};
void lisp_lib_load(LispContext ctx)
@@ -2111,14 +2108,14 @@ void lisp_lib_load(LispContext ctx)
lisp_table_set(
table,
lisp_make_symbol("_CURRENT-OUTPUT-PORT", ctx),
lisp_make_symbol("_current-output-port", ctx),
lisp_make_port(stdout, 0),
ctx
);
lisp_table_set(
table,
lisp_make_symbol("_CURRENT-INPUT-PORT", ctx),
lisp_make_symbol("_current-input-port", ctx),
lisp_make_port(stdin, 1),
ctx
);
+2
View File
@@ -10,6 +10,8 @@
int editorRowCxToRx(erow *row, int cursor_x);
int editorRowRxToCx(erow *row, int rx);
void editorUpdateRow(erow *row);
void editorInsertRow(int at, char *s, size_t len);
+20
View File
@@ -0,0 +1,20 @@
#define COLOR_RESET "\033[0m"
#define COLOR_KEYWORD "\033[1;35m" // Bold magenta
#define COLOR_TYPE "\033[1;34m" // Bold blue
#define COLOR_STRING "\033[1;32m" // Bold green
#define COLOR_COMMENT "\033[0;36m" // Cyan
#define COLOR_NUMBER "\033[1;33m" // Bold yellow
#define COLOR_DEFAULT "\033[0;37m" // White
// Token types
typedef enum {
TOKEN_KEYWORD,
TOKEN_TYPE,
TOKEN_STRING,
TOKEN_COMMENT,
TOKEN_NUMBER,
TOKEN_OPERATOR,
TOKEN_DEFAULT
} TokenType;
char *highlight_line(const char * line, int *length);
Executable
+43
View File
@@ -0,0 +1,43 @@
#!/bin/bash
echo "--- Welcome to Beluga installer ---"
read -p "Do you want to start the installation ? (Y/n)" confirm && [[ $confirm == [yY] || $confirm == [yY][eE][sS] ]] || exit 1
# Check dependencies
if ! command -v "meson" &>/dev/null; then
echo "❌ Error: meson not found. Please install it first."
exit 1
fi
# Create config files
echo "Create config files ..."
mkdir -pv ~/.beluga/
cp -rv ./assets/ ~/.beluga/
mkdir -pv ~/.beluga/packages/
mkdir -pv ~/.beluga/config/
read -p "Do you want to replace your config file or keep it (init.lisp.bak) / (init.lisp.new) ? (Y/n)" confirm
if [[ "$confirm" =~ ^[Yy]$ ]]; then
mv ~/.beluga/config/init.lisp ~/.beluga/config/init.lisp.bak
cp -rv ./config/init.lisp ~/.beluga/config/
else
cp -rv ./config/init.lisp ~/.beluga/config/init.lisp.new
fi
# Compile the project
echo "Start compilation ..."
meson setup build/
meson compile -C build/
# Add to path
echo "Adding beluga to the path"
sudo cp -f ./build/beluga /usr/local/bin/
echo "Installation finish"
echo "Check ~/.beluga/config/init.lisp for customization"
-27
View File
@@ -1,27 +0,0 @@
*.out
/lisp
*.exe
*.stackdump
temp/
/printer
/sample
# Xcode
.DS_Store
build/
*.pbxuser
!default.pbxuser
*.mode1v3
!default.mode1v3
*.mode2v3
!default.mode2v3
*.perspectivev3
!default.perspectivev3
*.xcworkspace
!default.xcworkspace
xcuserdata
profile
*.moved-aside
DerivedData
.idea/
-64
View File
@@ -1,64 +0,0 @@
# Internals
Technical design decisions and tricks.
## Memory
We do not use tagged pointers, for simplicity and portability.
`Lisp` objects are fairly large due to alignment requirements (16 bytes).
However, they are usually only stored in this form when interacting
in the C stack. In data structures, we prefer to store `LispVal` (8 bytes)
and pack the types in with the block info.
All allocations are aligned to `sizeof(LispVal)` to avoid unaligned access.
- [Chicken representation](http://www.more-magic.net/posts/internals-data-representation.html)
## Garbage Collection
The choice to use explicit, rather than automatic garbage collection, was made so that the interpreter does not need to keep track of every lisp object on the stack, only the most important objects.
If garbage collection was allowed to trigger at any time in the middle of a C function call, then the interpreter would need to be able to "see" all the lisp values on the call stack, in order to prevent them from being collected. Providing this feature would make integrating with C code much more complicated and conflict with the project's goal of being easily embeddable.
This means that when `lisp_collect` is called, all lisp values which are not reachable from the global environment or the function's parameters become invalidated. Be conscious of when and where you call the garbage collector.
An alternative solution is used in [Lua][lua-memory].
The interpreter uses the [Cheney algorithim][cheney-mta] for garbage collection. Memory is allocated in fixed size pages. When an allocation is request and the current page does not have enough space remaining, a new page will be allocated to fulfill the allocation. So, allocations will continue to use up more memory until garbage collection.
Note that tail call recursion will not overflow the stack, but will use additional memory for each function call.
[cheney-mta]: https://en.wikipedia.org/wiki/Cheney%27s_algorithm
[mta-info]: http://home.pipeline.com/~hbaker1/CheneyMTA.html
[lua-memory]: https://www.lua.org/pil/24.2.html
[gc-internals]: http://www.more-magic.net/posts/internals-gc.html
## General design
- [Lysp][lysp]
- [Lispy][lispy]
[lysp]: http://piumarta.com/software/lysp/
[lispy]: http://norvig.com/lispy.html
## Environments/Tables
Tables are only resized at garbage collect time.
This leads us to linked list-chaining as opposed to open addresing
because linked list chaining can scale infinitely while
waiting for garbage collection.
- [SICP][sicp-environments]
- [MIT][environment-objects]
[sicp-environments]: https://mitpress.mit.edu/sicp/full-text/book/book-Z-H-21.html#%_sec_3.2
[environment-objects]: https://groups.csail.mit.edu/mac/ftpdir/scheme-7.4/doc-html/scheme_14.html
What is the cost of a helper (nested) function?
It must allocate a new lambda, but it doesn't have to read/expand it again.
## Symbols
- Reference counting symbol table? - http://sandbox.mc.edu/~bennet/cs404/ex/lisprcnt.html
-26
View File
@@ -1,26 +0,0 @@
CFLAGS = -Idist/ -Wall -pedantic -Wstrict-prototypes -O3
LDLIBS = -lm
CC=cc
all: lisp printer sample
clean:
rm -f lisp
rm -f printer
rm -f sample
rm -f dist/lisp_lib.h
lisp: repl.c dist/lisp.h dist/lisp_lib.h
${CC} repl.c -o $@ ${CFLAGS} ${LDLIBS}
printer: printer.c dist/lisp.h
${CC} printer.c -o $@ ${CFLAGS} ${LDLIBS}
sample: sample.c dist/lisp.h dist/lisp_lib.h
${CC} sample.c -o $@ ${CFLAGS} ${LDLIBS}
dist/lisp_lib.h: stdlib/lib.h stdlib/lib.c
cd stdlib; ./concat.sh > ../$@;
.PHONY: all clean
-207
View File
@@ -1,207 +0,0 @@
Lisp Interpreter
================
> Any sufficiently complicated C or Fortran program contains an ad hoc, informally-specified, bug-ridden, slow implementation of half of Common Lisp. -- Philip Greenspun
An embeddable lisp/scheme interpreter written in C.
It includes a subset of R5RS with some extensions from MIT Scheme.
I created this while reading [SICP](https://github.com/justinmeiners/sicp-excercises) to improve my knowledge of lisp
and to make an implementation that allows me to easily add scripting to my own programs.
### Philosophy
- **Simple**: This project doesn't aim to be optimal, or fully standards compliant.
It is just a robust foundation for scripting.
It is implemented as a recursive AST walker on the C stack.
If you need more try [s7](https://ccrma.stanford.edu/software/snd/snd/s7.html) or [chicken](https://www.call-cc.org)
- **Unintrusive**: Just copy in the header file. Turn on and off major features with build macros. It should be portable between major platforms.
- **Unsurprising**: You should be able to read the source code and understand how it works.
The C API should work how you expect.
- **First class data**: Lisp s-expressions are undervalued as an alternative to JSON or XML.
Preprocessor flags can remove most scheme features if you just want to read s-expressions
and manipulate them in C.
### Features
- C99, no dependencies, two files.
- Core lisp language `if`, `let`, `do`, `lambda`, `cons`, `eval`, etc.
- Subset of scheme R5RS library: lists, vectors, hash tables, integers, real numbers, characters, strings, and integers.
- Common lisp goodies: unhygenic macros (`define-macro`), `push`, `dotimes`.
- Easy to integrate C functions.
- Exact [garbage collection](#garbage-collection) with explicit invocation.
- REPL command line tool.
- Efficient parsing and manipulation of large data files.
### Non-Features
- Compiler or VM.
- Full numeric tower.
- Full call/cc. This only supports simple stack jumps.
- syntax rules.
- UNIX system interface/IO library.
### Examples
### Interactive programming with Read, eval, print loop.
```bash
$ ./lisp
> (define (sqr x) (* x x)))
> (define length 40)
> (define area 0)
> (set! area (sqr length))
1600
```
### Quickstart
```c
LispContext ctx = lisp_init();
lisp_load_lib(ctx);
LispError error;
Lisp program = lisp_read("(+ 1 2)", &error, ctx);
Lisp result = lisp_eval(program, &error, ctx);
if (error != LISP_ERROR_NONE)
lisp_print(result); ; => 3
lisp_shutdown(ctx);
```
### Loading Data
Lisp s-expressions can be used as a lightweight substitute to JSON or XML.
Looking up keys which are reused is even more efficient due to symbol comparison.
JSON
```json
{
"name" : "Bob Jones",
"age" : 54,
"city" : "SLC",
}
```
Lisp
```scheme
#((name . "Bob Jones")
(age . 54)
(city . "SLC"))
```
Loading the structure in C.
```c
LispContext ctx = lisp_init();
// load lisp structure
Lisp data = lisp_read_file(file, ctx);
// get value for age
Lisp age_entry = lisp_avector_ref(data, lisp_make_symbol("AGE", ctx), ctx);
// ...
lisp_shutdown(ctx);
```
### Calling C functions
C functions can be used to extend the interpreter, or call into C code.
```c
Lisp integer_range(Lisp args, LispError* e, LispContext ctx)
{
// first argument
LispInt start = lisp_int(lisp_car(args));
args = lisp_cdr(args);
// second argument
LispInt end = lisp_int(lisp_car(args));
if (end < start)
{
*e = LISP_ERROR_OUT_OF_BOUNDS;
return lisp_null();
}
LispInt n = end - start;
Lisp numbers = lisp_make_vector(n, ctx);
for (LispInt i = 0; i < n; ++i)
lisp_vector_set(numbers, i, lisp_make_int(start + i));
return numbers;
}
// ...
// wrap in Lisp object
Lisp func = lisp_make_func(integers_in_range);
// add to enviornment with symbol INTEGER-RANGE
Lisp env = lisp_env_global(ctx);
lisp_env_define(env, lisp_make_symbol("INTEGER-RANGE", ctx), func, ctx);
```
In Lisp
```scheme
(integer-range 5 15)
; => #(5 6 7 8 9 10 11 12 13 14)
```
Constants can also be stored in the environment in a similar fashion.
```c
Lisp pi = lisp_make_real(3.141592);
lisp_env_define(env, lisp_make_symbol("PI", ctx), pi, ctx);
```
### Macros
Common Lisp style (`defmacro`) is available with the name `define-macro`.
(define-macro nil! (lambda (x)
`(set! ,x '()))
### Garbage Collection
Garbage is only collected if it is explicitly told to.
You can invoke the garbage collector in C:
lisp_collect(ctx);
OR in lisp code:
(gc-flip)
Note that whenever a collect is issued
ANY `Lisp` value in `C`which is not accessible
through the global environment may become invalid.
Be careful what variables you hold onto in C.
Don't call `eval` in a custom defined C function unless you know what you are doing.
See [internals](INTERNALS.md) for more details.
## Documentation
For the language refer to [MIT Scheme](https://groups.csail.mit.edu/mac/ftpdir/scheme-7.4/doc-html/scheme_toc.html)
with the understanding that not everything is missing.
If we do implement a feature that MIT scheme has, we will try to follow their specificaiton.
For the C API refer to the header and sample programs (`repl.c`, `printer.c`).
## Project License
Copyright (c) 2020 Justin Meiners
Permission to use, copy, modify, and distribute this software for any
purpose with or without fee is hereby granted, provided that the above
copyright notice and this permission notice appear in all copies.
THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
-24
View File
@@ -1,24 +0,0 @@
#include <stdlib.h>
#include <time.h>
#include <string.h>
#define LISP_IMPLEMENTATION
#include "lisp.h"
int main(int argc, const char* argv[])
{
LispContext ctx = lisp_init();
LispError error;
Lisp data = lisp_read_file(stdin, &error, ctx);
if (error != LISP_ERROR_NONE)
{
fprintf(stderr, "error: %s\n", lisp_error_string(error));
}
data = lisp_collect(data, ctx);
lisp_printf(stdout, data);
lisp_shutdown(ctx);
return 0;
}
-163
View File
@@ -1,163 +0,0 @@
#include <stdlib.h>
#include <time.h>
#include <string.h>
// Disable asserts?
// #define NDEBUG
//#define LISP_DEBUG
#define LISP_IMPLEMENTATION
#include "lisp.h"
#include "lisp_lib.h"
#define LINE_MAX 4096
static Lisp sch_load(Lisp args, LispError* e, LispContext ctx)
{
Lisp path = lisp_car(args);
Lisp result = lisp_read_path(lisp_string(path), e, ctx);
if (*e != LISP_ERROR_NONE) return lisp_null();
return lisp_eval(result, e, ctx);
}
int main(int argc, const char* argv[])
{
const char* file_path = NULL;
int run_script = 0;
int verbose;
#ifdef LISP_DEBUG
verbose = 1;
#else
verbose = 0;
#endif
for (int i = 1; i < argc; ++i)
{
if (strcmp(argv[i], "--load") == 0)
{
file_path = argv[i + 1];
}
if (strcmp(argv[i], "--script") == 0)
{
file_path = argv[i + 1];
run_script = 1;
}
}
//LispContext ctx = lisp_init();
LispContext ctx = lisp_init_with_lib();
lisp_env_define(
lisp_cdr(lisp_env(ctx)),
lisp_make_symbol("LOAD", ctx),
lisp_make_func(sch_load),
ctx
);
// Load as a macro is called "include" and can be used to load files containing macros.
lisp_table_set(
lisp_macro_table(ctx),
lisp_make_symbol("INCLUDE", ctx),
lisp_make_func(sch_load),
ctx
);
clock_t start_time, end_time;
if (file_path)
{
if (verbose)
{
printf("loading: %s\n", file_path);
}
start_time = clock();
LispError error;
Lisp l = lisp_read_path(file_path, &error, ctx);
if (error != LISP_ERROR_NONE)
{
fprintf(stderr, "%s. %s\n", file_path, lisp_error_string(error));
}
end_time = clock();
if (verbose)
printf("read (us): %lu\n", 1000000 * (end_time - start_time) / CLOCKS_PER_SEC);
start_time = clock();
Lisp code = lisp_macroexpand(l, &error, ctx);
if (error != LISP_ERROR_NONE)
{
fprintf(stderr, "%s\n", lisp_error_string(error));
exit(1);
}
end_time = clock();
if (verbose)
printf("expand (us): %lu\n", 1000000 * (end_time - start_time) / CLOCKS_PER_SEC);
start_time = clock();
lisp_eval(code, &error, ctx);
end_time = clock();
if (error != LISP_ERROR_NONE)
{
fprintf(stderr, "%s\n", lisp_error_string(error));
exit(1);
}
lisp_collect(lisp_null(), ctx);
if (verbose)
printf("eval (us): %lu\n", 1000000 * (end_time - start_time) / CLOCKS_PER_SEC);
}
if (!run_script)
{
// REPL
while (!feof(stdin))
{
printf("> ");
char line[LINE_MAX];
if (!fgets(line, LINE_MAX, stdin)) break;
clock_t start_time = clock();
LispError error;
Lisp code = lisp_read(line, &error, ctx);
if (error != LISP_ERROR_NONE)
{
fprintf(stderr, "%s\n", lisp_error_string(error));
continue;
}
Lisp l = lisp_eval(code, &error, ctx);
clock_t end_time = clock();
if (error != LISP_ERROR_NONE)
{
fprintf(stderr, "%s\n", lisp_error_string(error));
}
lisp_printf(stdout, l);
printf("\n");
lisp_collect(lisp_null(), ctx);
if (verbose)
printf("(us): %lu\n", 1000000 * (end_time - start_time) / CLOCKS_PER_SEC);
}
}
lisp_shutdown(ctx);
return 0;
}
-57
View File
@@ -1,57 +0,0 @@
#!/bin/sh
PASS=1
cd tests/code
for FILE in *.scm
do
echo "$FILE"
../../lisp --script "$FILE"
RESULT=$?
printf "\n"
if [ $RESULT = "0" ]
then
echo "FINISHED $FILE"
else
echo "*FAILED* $FILE"
PASS=0
fi
printf "\n"
done
cd ../
cd data
( ./test.sh )
RESULT=$?
if [ $RESULT = "0" ]
then
echo "FINISHED data test"
else
echo "*FAILED* data test"
PASS=0
fi
cd ../
cd printer
( ./test.sh )
RESULT=$?
if [ $RESULT = "0" ]
then
echo "FINISHED printer test"
else
echo "*FAILED* printer test"
PASS=0
fi
if [ $PASS = "0" ]
then
echo "**TESTS FAILED**"
else
echo "**TESTS PASSED**"
fi
-55
View File
@@ -1,55 +0,0 @@
#include <stdlib.h>
#include <time.h>
#include <string.h>
#define LISP_IMPLEMENTATION
#include "lisp.h"
#include "lisp_lib.h"
Lisp integer_range(Lisp args, LispError* e, LispContext ctx)
{
// first argument
LispInt start = lisp_int(lisp_car(args));
args = lisp_cdr(args);
// second argument
LispInt end = lisp_int(lisp_car(args));
if (end < start)
{
*e = LISP_ERROR_OUT_OF_BOUNDS;
return lisp_null();
}
LispInt n = end - start;
Lisp numbers = lisp_make_vector(n, ctx);
for (LispInt i = 0; i < n; ++i)
lisp_vector_set(numbers, i, lisp_make_int(start + i));
return numbers;
}
int main(int argc, const char* argv[])
{
LispContext ctx = lisp_init();
lisp_lib_load(ctx);
// wrap in Lisp object
Lisp func = lisp_make_func(integer_range);
// add to enviornment with symbol INTEGER-RANGE
Lisp env = lisp_env(ctx);
lisp_env_define(env, lisp_make_symbol("INTEGER-RANGE", ctx), func, ctx);
Lisp pi = lisp_make_real(3.141592);
lisp_env_define(env, lisp_make_symbol("PI", ctx), pi, ctx);
LispError e;
Lisp result = lisp_eval(lisp_read("(INTEGER-RANGE 5 15)", &e, ctx), &e, ctx);
lisp_printf(stdout, result);
if (e != LISP_ERROR_NONE) fprintf(stderr, "error: %s\n", lisp_error_string(e));
lisp_shutdown(ctx);
return 0;
}
-90
View File
@@ -1,90 +0,0 @@
(define-macro lambda (/\_ args
(if (pair? args)
(if (pair? (cdr args))
(if (pair? (cdr (cdr args)))
`(/\_ ,(car args) ,(cons 'BEGIN (cdr args)))
`(/\_ ,(car args) ,(car (cdr args))))
(syntax-error "lambda missing body expressions: (lambda (args) body)"))
(syntax-error "lambda missing argument: (lambda (args) body)"))))
(define-macro set! (lambda (var x)
(begin
(if (not (symbol? var)) (syntax-error "set! not a variable"))
`(_SET! ,var ,x))))
(define-macro define
(lambda (var . exprs)
(if (symbol? var)
(if (pair? (cdr exprs))
(syntax-error "define: (define var x)")
`(_DEF ,var ,(car exprs)))
(if (pair? var)
`(_DEF ,(car var)
(LAMBDA ,(cdr var)
,(if (null? (cdr exprs)) (car exprs) (cons 'BEGIN exprs))))
(syntax-error "define: not a symbol") ))))
(define (first x) (car x))
(define (second x) (car (cdr x)))
(define (third x) (car (cdr (cdr x))))
(define (some? pred l)
(if (null? l) #f
(if (pred (car l)) #t
(some? pred (cdr l)))))
(define (_map1-helper proc l result)
(if (null? l)
(reverse! result)
(_map1-helper proc
(cdr l)
(cons (proc (car l)) result))))
(define (map1 proc l) (_map1-helper proc l '()))
(define (for-each1 proc l)
(if (null? l) '()
(begin (proc (car l)) (for-each1 proc (cdr l )))))
(define (reverse! l) (append-reverse! l '()))
(define (reverse l) (reverse! (list-copy l)))
(define (last-pair x)
(if (pair? (cdr x))
(last-pair (cdr x)) x))
(define (list-tail x k)
(if (zero? k) x
(list-tail (cdr x) (- k 1))))
(define (fold-left op acc lst)
(if (null? lst) acc
(fold-left op (op acc (car lst)) (cdr lst))))
(define (_expand-shorthand-body path)
(if (null? path) (cons 'pair '())
(list (if (char=? (car path) #\A)
(cons 'CAR (_expand-shorthand-body (cdr path)))))))
(define (_expand-shorthand text)
(cons 'DEFINE (cons (list (string->symbol (string-append "C" text "R")) 'pair)
(_expand-shorthand-body (string->list text)))))
(define-macro _shorthand-accessors (lambda args (cons 'BEGIN (map1 _expand-shorthand args))))
(define (vector . args) (list->vector args))
(define (vector-copy v) (subvector v 0 (vector-length v)))
(define (vector-head v end) (subvector v 0 end))
(define (vector-tail v start) (subvector v start (vector-length v)))
(define (string . chars) (list->string chars))
(define (string>=? a b) (not (string<? a b)))
(define (string>? a b) (string<? b a))
(define (string<=? a b) (not (string<? b a)))
(define (string-copy s) (substring s 0 (string-length v)))
(define (string-head s end) (subvector s 0 end))
(define (string-tail s start) (subvector s start (string-length v)))
-78
View File
@@ -1,78 +0,0 @@
(define (_make-lambda args body)
(list 'LAMBDA args (if (null? (cdr body)) (car body) (cons 'BEGIN body))))
; (LET <name> ((<var0> <expr0>) ... (<varN> <expr1>)) <body0> ... <bodyN>)
; => ((LAMBDA (<var0> ... <varN>) (BEGIN <body0> ... <bodyN>)) <expr0> ... <expr1>)
; => named
; ((lambda ()
; (define <name> (LAMBDA (<var0> ... <varN>) (BEGIN <body0> ... <bodyN>)))
; (<name> <expr0> ... <exprN>)))
(define (_check-binding-list bindings)
(for-each1 (lambda (entry)
(if (not (pair? entry)) (syntax-error "bad let binding" entry))
(if (not (symbol? (first entry))) (syntax-error "let entry missing symbol" entry))) bindings))
(define (_let->combination var bindings body)
(_check-binding-list bindings)
(define body-func (_make-lambda (map1 (lambda (entry) (first entry)) bindings) body))
(define initial-args (map1 (lambda (entry) (second entry)) bindings))
(if (null? var)
(cons body-func initial-args)
(list (_make-lambda '() (list (list 'DEFINE var body-func) (cons var initial-args))))))
(define-macro let (lambda args
(if (pair? (first args))
(_let->combination '() (car args) (cdr args))
(_let->combination (first args) (second args) (cdr (cdr args))))))
(define (_let*-helper bindings body)
(if (null? bindings) (if (null? (cdr body)) (car body) (cons 'BEGIN body))
(list 'LET (list (car bindings)) (_let*-helper (cdr bindings) body))))
(define-macro let* (lambda (bindings . body)
(_check-binding-list bindings)
(_let*-helper bindings body)))
(define-macro letrec (lambda (bindings . body)
(_check-binding-list bindings)
(cons (_make-lambda (map1 (lambda (entry) (first entry)) bindings)
(append (map1 (lambda (entry) (list 'SET! (first entry) (second entry)))
bindings) body))
(map1 (lambda (entry) '()) bindings))))
; (COND (<pred0> <expr0>)
; (<pred1> <expr1>)
; ...
; (else <expr-1>))
; =>
; (IF <pred0> <expr0>
; (if <pred1> <expr1>
; ....
; (if <predN> <exprN> <expr-1>)) ... )
(define (_cond-check-clauses clauses)
(for-each1 (lambda (clause)
(if (not (pair? clause)) (syntax-error "cond: invalid clause"))
(if (null? (cdr clause)) (syntax-error "cond: clause missing expression")))
clauses))
(define (_cond-helper clauses)
(if (null? clauses) '()
(if (eq? (car (car clauses)) 'ELSE)
(cons 'BEGIN (cdr (car clauses)))
(list 'IF
(car (car clauses))
(cons 'BEGIN (cdr (car clauses)))
(_cond-helper (cdr clauses))))))
(define-macro cond (lambda clauses
(begin
(_cond-check-clauses clauses)
(_cond-helper clauses))))
-75
View File
@@ -1,75 +0,0 @@
(_shorthand-accessors "AA" "DD" "AD" "DA" "AAA" "AAD" "ADA" "DAA" "ADD" "DAD" "DDA" "DDD")
(define (_and-helper preds)
(cond ((null? preds) #t)
((null? (cdr preds)) (car preds))
(else
`(IF ,(car preds) ,(_and-helper (cdr preds)) #f))))
(define-macro and (lambda preds (_and-helper preds)))
(define (_or-helper preds var)
(cond ((null? preds) #f)
((null? (cdr preds)) (car preds))
(else
`(BEGIN (SET! ,var ,(car preds))
(IF ,var ,var ,(_or-helper (cdr preds) var))))))
(define-macro or (lambda preds
(let ((var (gensym)))
`(LET ((,var '())) ,(_or-helper preds var)))))
(define-macro case (lambda (key . clauses)
(let ((expr (gensym)))
`(LET ((,expr ,key))
,(cons 'COND (map1 (lambda (entry)
(cons (if (pair? (car entry))
`(MEMV ,expr (quote ,(car entry)))
(car entry))
(cdr entry))) clauses))))))
(define-macro push
(lambda (v l)
`(begin (set! ,l (cons ,v ,l)) ,l)))
; (DO ((<var0> <init0> <step0>) ...) (<test> <result>) <body>)
(define-macro do
(lambda (vars loop-check . loops)
(let ( (names '()) (inits '()) (steps '()) (f (gensym)) )
(for-each1 (lambda (var)
(push (car var) names)
(set! var (cdr var))
(push (car var) inits)
(set! var (cdr var))
(push (car var) steps)) vars)
`((LAMBDA ()
(DEFINE ,f (LAMBDA ,names
(IF ,(car loop-check)
,(if (pair? (cdr loop-check)) (car (cdr loop-check)) '())
,(cons 'BEGIN (append loops (list (cons f steps)))) )))
,(cons f inits)
)) )))
(define-macro dotimes
(lambda (form body)
(apply (lambda (i n . result)
`(DO ((,i 0 (+ ,i 1)))
((>= ,i ,n) ,(if (null? result) result (car result)) )
,body)
) form)))
(define-macro swap!
(lambda (x y)
(let ((temp (gensym)))
`(LET ((,temp ,x))
(SET! ,temp ,x)
(SET! ,x ,y)
(SET! ,y ,temp)))))
(define-macro inc! ; CL incf
(lambda (x)
`(SET! ,x (+ ,x 1))))
(define-macro dec! ; CL decf
(lambda (x)
`(SET! ,x (- ,x 1))))
-35
View File
@@ -1,35 +0,0 @@
(define (number? x) (real? x))
(define (odd? x) (not (even? x)))
(define (inexact? x) (not (exact? x)))
(define (zero? x) (= x 0))
(define (positive? x) (>= x 0))
(define (negative? x) (< x 0))
(define (>= a b) (not (< a b)))
(define (> a b) (< b a))
(define (<= a b) (not (< b a)))
(define (max . ls)
(fold-left (lambda (m x)
(if (> x m)
x
m)) (car ls) (cdr ls)))
(define (min . ls)
(fold-left (lambda (m x)
(if (< x m)
x
m)) (car ls) (cdr ls)))
(define (_gcd-helper a b)
(if (= b 0) a (_gcd-helper b (modulo a b))))
(define (gcd . args)
(if (null? args) 0
(_gcd-helper (car args) (car (cdr args)))))
(define (lcm . args)
(if (null? args) 1
(abs (* (/ (car args) (apply gcd args))
(apply * (cdr args))))))
-133
View File
@@ -1,133 +0,0 @@
(define (map proc . rest)
(define (helper lists result)
(if (some? null? lists)
(reverse! result)
(helper (map1 cdr lists)
(cons (apply proc (map1 car lists)) result))))
(helper rest '()))
(define (for-each proc . rest)
(define (helper lists)
(if (some? null? lists)
'()
(begin
(apply proc (map1 car lists))
(helper (map1 cdr lists)))))
(helper rest))
(define (filter pred l)
(define (helper l result)
(cond ((null? l) result)
((pred (car l))
(helper (cdr l) (cons (car l) result)))
(else
(helper (cdr l) result))))
(reverse! (helper l '())))
(define (reduce op default lst)
(if (null? lst)
default
(fold-left op (car lst) (cdr lst))))
(define (alist->hash-table alist)
(define h (make-hash-table))
(for-each1 (lambda (pair)
(hash-table-set! h (car pair) (cdr pair))) alist)
h)
(define (_assoc key list eq?)
(if (null? list) #f
(let ((pair (car list)))
(if (and (pair? pair) (eq? key (car pair)))
pair
(_assoc key (cdr list) eq?)))))
(define (assoc key list) (_assoc key list equal?))
(define (assq key list) (_assoc key list eq?))
(define (assv key list) (_assoc key list eqv?))
(define (_member x list eq?)
(cond ((null? list) #f)
((eq? (car list) x) list)
(else (_member x (cdr list) eq?))))
(define (member x list) (_member x list equal?))
(define (memq x list) (_member x list eq?))
(define (memv x list) (_member x list eqv?))
(define (make-initialized-vector l fn)
(let ((v (make-vector l '())))
(do ((i 0 (+ i 1)))
((>= i l) v)
(vector-set! v i (fn i)))))
(define (vector-map fn v)
(make-initialized-vector
(vector-length v)
(lambda (i) (fn (vector-ref v i)))))
(define (vector-binary-search v key< unwrap-key key)
(define (helper low high mid)
(if (<= (- high low) 1)
(if (key< (unwrap-key (vector-ref v low)) key) #f (vector-ref v low))
(begin
(set! mid (+ low (quotient (- high low) 2)))
(if (key< key (unwrap-key (vector-ref v mid)))
(helper low mid 0)
(helper mid high 0)))))
(helper 0 (vector-length v) 0))
(define (_insertsort v lo hi op)
(if (= (- hi lo) 0)
v
(do ((i (+ lo 1) (+ i 1)))
((= i hi) v)
(define x (vector-ref v i))
(do ((j i (- j 1)))
((or
(= j lo)
(not (op x (vector-ref v (- j 1)))))
(vector-set! v j x))
(vector-set! v j (vector-ref v (- j 1))))) ))
(define (_quicksort-partition v lo hi op)
(let ((pivot (vector-ref v (+ lo (/ (- hi lo) 2))))
(i (- lo 1))
(j (+ hi 1)))
(do ()
((>= i j) j)
(set! i (+ i 1))
(do ()
((not (op (vector-ref v i) pivot)) '())
(set! i (+ i 1)))
(set! j (- j 1))
(do ()
((not (op pivot (vector-ref v j))) '())
(set! j (- j 1)))
(if (< i j) (vector-swap! v i j))
)))
(define (_quicksort-vector v lo hi threshold op)
(if (and (>= lo 0) (>= hi 0) (< lo hi) (> (- hi lo) threshold))
(let ((p (_quicksort-partition v lo hi op)))
(_quicksort-vector v lo p threshold op)
(_quicksort-vector v (+ p 1) hi threshold op))))
(define (sort! v op)
; quicksort down to a certain level of recursion and
; then use insertion sort to finalize.
(_quicksort-vector v 0 (- (vector-length v) 1) 16 op)
(_insertsort v 0 (vector-length v) op)
v)
(define (sort list cmp) (vector->list (sort! (list->vector list) cmp)))
-58
View File
@@ -1,58 +0,0 @@
(define-macro delay (lambda (expr)
`(make-promise ,(cons 'LAMBDA
(cons '()
(cons expr '()))))))
(define (force promise)
(if (not (promise-forced? promise))
(_promise-store! promise ((_promise-procedure promise))))
(promise-value promise))
(define-macro cons-stream (lambda (x expr) `(cons ,x (delay ,expr))))
(define (stream-car stream) (car stream))
(define (stream-cdr stream) (force (cdr stream)))
(define (stream-pair? x)
(and (pair? x) (promise? (cdr x))))
(define (stream-null? stream) (null? stream))
(define (stream->list-helper stream result)
(if (stream-null? stream)
(reverse! result)
(stream->list-helper
(force (cdr stream))
(cons (car stream) result))))
(define (stream->list stream)
(stream->list-helper stream '()))
(define (list->stream list)
(if (null? list)
'()
(cons-stream (car list) (list->stream (cdr list)))))
(define (stream . args) (list->stream args))
(define (stream-head-helper stream k result)
(if (= k 0)
(reverse! result)
(stream-head-helper (force (cdr stream)) (- k 1) (cons (car stream) result))))
(define (stream-head stream k)
(stream-head-helper stream k '()))
(define (stream-tail stream k)
(if (= k 0)
stream
(stream-tail (stream-cdr stream) (- k 1))))
(define (stream-filter pred stream)
(cond ((stream-null? stream) the-empty-stream)
((pred (stream-car stream))
(cons-stream (stream-car stream)
(stream-filter pred
(stream-cdr stream))))
(else (stream-filter pred (stream-cdr stream)))))
-63
View File
@@ -1,63 +0,0 @@
(define (char>=? a b) (not (char<? a b)))
(define (char>? a b) (char<? b a))
(define (char<=? a b) (not (char<? b a)))
(define (char-ci=? a b) (char=? (char-downcase a) (char-downcase b)))
(define (char-ci<? a b) (char<? (char-downcase a) (char-downcase b)))
(define (char-ci>=? a b) (not (char-ci<? a b)))
(define (char-ci>? a b) (char-ci<? b a))
(define (char-ci<=? a b) (not (char-ci<? b a)))
(define (char-lower-case? c)
(and (>= (char->integer c) (char->integer #\a))
(<= (char->integer c) (char->integer #\z))))
(define (char-upper-case? c)
(and (>= (char->integer c) (char->integer #\A))
(<= (char->integer c) (char->integer #\Z))))
(define (procedure? p) (or (compiled-procedure? p) (compound-procedure? p)))
(define (current-input-port) _current-input-port)
(define (current-output-port) _current-output-port)
(define (read . args)
(_read (if (null? args)
(current-input-port)
(car args))))
(define (write obj . args)
(_write obj (if (null? args)
(current-output-port)
(car args))))
(define (display obj . args)
(_display obj (if (null? args)
(current-output-port)
(car args))))
(define (write-char obj . args)
(_write-char obj (if (null? args)
(current-output-port)
(car args))))
(define (flush-output-port . args)
(_flush-output-port (if (null? args)
(current-output-port)
(car args))))
(define (newline) (write-char #\newline))
(define-macro assert (lambda (body)
`(if ,body '()
(begin
(display (quote ,body))
(error " assert failed")))))
(define-macro ==> (lambda (test expected)
`(assert (equal? ,test (quote ,expected))) ))
-20
View File
@@ -1,20 +0,0 @@
#!/bin/bash
SRC=*.scm
cat lib.h
echo "// Generated from scheme source."
echo "#ifdef LISP_IMPLEMENTATION"
for FILE in $SRC
do
echo "static const char* lib_$(basename $FILE .scm)_src_ = "
cat $FILE | ./text2c.sh
echo ";"
echo ""
done
cat lib.c
echo "#endif"
File diff suppressed because it is too large Load Diff
-31
View File
@@ -1,31 +0,0 @@
/*
Created by: Justin Meiners
Repo; https://github.com/justinmeiners/lisp-interpreter
License: MIT (See end if file)
This file contains the scheme standard library.
See lisp.h for insructions.
*/
#ifndef LISP_LIB_H
#define LISP_LIB_H
#ifdef __cplusplus
extern "C" {
#endif
#include <stdio.h>
#include <stdint.h>
void lisp_lib_load(LispContext ctx);
// convenience for init and load
LispContext lisp_init_with_lib(void);
#ifdef __cplusplus
}
#endif
#endif
-9
View File
@@ -1,9 +0,0 @@
#!/bin/bash
read -r -d '' content
content=${content//'\'/'\\'}
content=${content//$'\t'/'\t'}
content=${content//$'\n'/$' \\n\\\n'}
content=${content//$'\r'/'\r'}
content=${content//'"'/'\"'}
echo -n "\"$content\""
-78
View File
@@ -1,78 +0,0 @@
; a1 a2 ... an
; We must end up with n multiplications of three numbers.
; Each one must have a distinct ai in the middle.
; (* aj ai ak) where j < i and i < k.
; The neighboring elements are determined by the order of selection,
; so we can just look at the order of select elements. This is all the permutations
; of i in [1...n] so n! total possibilites.
; However, this also tells us how to estimate.
(defun smallest-index (array)
"requires: array is non-empty"
(prog ((smallest 0)
(i 0)
(N (length array)))
loop
(when (>= i N)
(return smallest))
(when (< (aref array i) (aref array smallest))
(setf smallest i))
(incf i)
(go loop)))
(defun ref (array i)
(if (or (< i 0) (>= i (length array)))
1
(aref array i)))
(defun estimate (array)
(if (= (length array) 1)
(aref array 0)
(let ((i (smallest-index array)))
(+
(*
(ref array i)
(ref array (- i 1))
(ref array (+ i 1)))
(estimate (concatenate 'vector
(subseq array 0 i)
(subseq array (+ i 1))))))))
(defun upper-bound (array)
(loop for i from 0 below (length array) sum
(* (reduce #'max (subseq array 0 i) :initial-value 1)
(aref array i)
(reduce #'max (subseq array (+ i 1)) :initial-value 1))))
(defun upper-bound2 (array)
(let ((N (length array))
(x (reduce #'max array)))
(+ (* (- N 2) (* x x x))
(* (* x x))
(* x))
))
(defun lower-bound2 (array)
(let ((N (length array))
(x (reduce #'min array)))
(+ (* (- N 2) (* x x x))
(* (* x x))
(* x))))
(print (estimate #(5 3 2 8)))
(print (estimate #(10 10 10 10 10 10)))
;(print (upper-bound #(5 3 2 8)))
;(print (lower-bound2 #(10 10 10 10 10 10)))
;(print (upper-bound2 #(10 10 10 10 10 10)))
@@ -1,34 +0,0 @@
; Find the largest palindrome made from the product of two 3-digit numbers.
; could be 6 digits
; 10^3 = 1,000 possible palindromes
; or 5 digits
; 10^3 = 1,000 possible palindromes
; 2,000 total
(define (palindrome? n)
(define (check i str)
(if (> (* i 2) (string-length str))
#t
(if (eq? (string-ref str i)
(string-ref str (- (string-length str) (+ i 1))))
(check (+ i 1) str)
#f)))
(check 0 (number->string n)))
(define nums '())
(do ((i 100 (+ i 1)))
((> i 999) 'done)
(do ((j 100 (+ j 1)))
((> j 999) 'done)
(let ((n (* i j)))
(if (>= n 100000)
(if (palindrome? n)
(push n nums)
)))))
(display (reduce max 0 nums))
-47
View File
@@ -1,47 +0,0 @@
(define large-num (string-append
"73167176531330624919225119674426574742355349194934"
"96983520312774506326239578318016984801869478851843"
"85861560789112949495459501737958331952853208805511"
"12540698747158523863050715693290963295227443043557"
"66896648950445244523161731856403098711121722383113"
"62229893423380308135336276614282806444486645238749"
"30358907296290491560440772390713810515859307960866"
"70172427121883998797908792274921901699720888093776"
"65727333001053367881220235421809751254540594752243"
"52584907711670556013604839586446706324415722155397"
"53697817977846174064955149290862569321978468622482"
"83972241375657056057490261407972968652414535100474"
"82166370484403199890008895243450658541227588666881"
"16427171479924442928230863465674813919123162824586"
"17866458359124566529476545682848912883142607690042"
"24219022671055626321111109370544217506941658960408"
"07198403850962455444362981230987879927244284909188"
"84580156166097919133875499200524063689912560717606"
"05886116467109405077541002256983155200055935729725"
"71636269561882670428252483600823257530420752963450"))
(define width 13)
(define (char->number c)
(if (char-numeric? c)
(- (char->integer c) (char->integer #\0))
-1))
(define (substring->numbers subs)
(map char->number (string->list subs)))
(define (iter i largest)
(if (>= (+ i width) (string-length large-num))
largest
(let* ((sub (substring large-num i (+ i width)))
(set (substring->numbers sub))
(product (apply * set)))
(if (> product (car largest))
(iter (+ i 1) (cons product set))
(iter (+ i 1) largest)))))
(display (iter 0 '(-1 . '())))
-56
View File
@@ -1,56 +0,0 @@
; add a test for every bug that is incountered
; to avoid recreating it in the future
; test basic vector creation and operations
(define v #(1 2 3 4 5 6 7 8 9 10))
(define (sum-to-n n) (/ (* n (+ n 1)) 2))
(define (sum-vector v)
(define (iter sum i)
(if (= i (vector-length v))
sum
(iter (+ sum (vector-ref v i)) (+ i 1))))
(iter 0 0))
(display "Sum to 10: ")
(display (sum-vector v))
(newline)
(assert (= (sum-to-n 10) (sum-vector v)))
; procedures with no arguments don't expand properly
(define (hello-world) (display "hello world") (newline))
(hello-world)
; vector and list assoc
(assert
(= (do ((i 1 (+ i 1)) (n 0 n))
((> i 10) n)
(set! n (+ i n)))
(* 5 11)))
(let ((sym (gensym)))
(assert (eq? sym sym)))
(assert (equal? (cons 2000 1) (cons 2000 1)))
(assert (equal? "apple" "apple"))
(assert (not (eq? 'DEFINE 'DEFINE-MACRO)))
(define (scope-test var)
(let ((var "dog"))
(==> var "dog"))
(==> var "cat"))
(scope-test "cat")
(define (scope-test-named var)
(let block-name ((var "dog"))
(==> var "dog"))
(==> var "cat"))
(scope-test-named "cat")
-59
View File
@@ -1,59 +0,0 @@
; PROBLEW
; W - maximum bag weight
; {m_1, m_2, ... m_n} = item weights
; {v_1, v_2, ... v_n} = item values
; want to choose a subset I so that
; sum m_i <= W
; and
; sum v_i is maximized
; In other words, if we choose another subset J
; then sum v_j <= sum v_i
(define (rand-item max-weight max-cost)
(cons (random max-weight)
(random max-cost)))
(define (build-items n)
(if (= n 0)
'()
(cons (rand-item 100 100)
(build-items (- n 1)))))
;(random-seed! (GET-UNIVERSAL-TIME))
;(define items (build-items 10))
(define items '((23 . 505) (26 . 352) (18 . 220) (32 . 354) (27 . 414) (29 . 498) (26 . 545) (30 . 473) (27 . 543)))
(define (knapsack remaining items)
(if (or (null? items) (<= remaining 0))
0
(let ((weight (car (car items)))
(val (cdr (car items))))
(max
(if (>= (- remaining weight) 0)
(+ val (knapsack (- remaining weight) (cdr items)))
0)
(knapsack remaining (cdr items))))))
(display (knapsack 67 items))
(assert (= (knapsack 67 items) 1270))
; https://en.wikipedia.org/wiki/Levenshtein_distance
(define (edit-distance-list a b eq?)
(cond ((null? a) (length b))
((null? b) (length a))
(else (min
(+ 1 (edit-distance-list (cdr a) b eq?)) ; insert
(+ 1 (edit-distance-list a (cdr b) eq?)) ; delete
(+
(if (eq? (car a) (car b)) 0 1) ; replace if needed
(edit-distance-list (cdr a) (cdr b) eq?))))))
(define (edit-distance a b)
(edit-distance-list (string->list a) (string->list b) char=?))
(==> (edit-distance "kitten" "sitting") 3)
@@ -1,5 +0,0 @@
(load "include/draw-tree.scm")
(dt '(a b c (d e f (g . h))))
(dt '((a) (b . c) (d e)))
-93
View File
@@ -1,93 +0,0 @@
; copy examples from MIT scheme documentation and add related ones.
; Conditionals
; https://www.gnu.org/software/mit-scheme/documentation/stable/mit-scheme-ref/Conditionals.html
(assert (and (= 2 2) (> 2 1)))
(assert (and))
(==> (and 3 2) 2)
(==> (and 1 2 'c '(f g)) (f g))
(==> (or #f #\a #f) #\a)
(==> (or (memq 'b '(a b c)) (/ 3 0)) (b c))
(define (bit-type x)
(cond ((= x 0) 'OFF)
((= x 1) 'ON)
(else 'UNKNOWN)))
(==> (bit-type 0) OFF)
(==> (bit-type 1) ON)
(==> (bit-type 25) UNKNOWN)
; https://groups.csail.mit.edu/mac/ftpdir/scheme-7.4/doc-html/scheme_13.html
; Universl Time https://www.gnu.org/software/mit-scheme/documentation/mit-scheme-ref/Universal-Time.html
(assert (integer? (get-universal-time)))
; https://www.gnu.org/software/mit-scheme/documentation/mit-scheme-ref/Procedure-Operations.html#Procedure-Operations
(assert (procedure? (lambda (x) x)))
(assert (compound-procedure? (lambda (x) x)))
(assert (not (compiled-procedure? (lambda (x) x))))
(assert (not (procedure? 3)))
(assert (= 18 (apply + (list 3 4 5 6))))
(assert (compiled-procedure? eval))
(let ((x "hello")
(y "world"))
(==> (string-append x y) "helloworld"))
(let* ((x 2)
(y (+ x 1)))
(==> (+ x y) 5))
(do ((i 0 (+ i 1)))
((>= i 10))
(assert (>= i 0))
(display i))
(==> (eval '(+ 2 2)) 4)
(==> (eval '(+ 2 2) (interaction-environment)) 4)
(assert (scheme-report-environment 5))
(assert (case (+ 2 3)
((2) #f)
((1 5) #t)))
(assert (case 7
((2) #f)
((1 5) #f)
(else #t)))
(assert (case 2
((2) #t)
((1 5) #f)
(else #f)))
(assert (letrec ((even?
(lambda (n)
(if (zero? n)
#t
(odd? (- n 1)))))
(odd?
(lambda (n)
(if (zero? n)
#f
(even? (- n 1))))))
(even? 88)))
(let ((x 0))
(inc! x)
(==> x 1)
(dec! x)
(==> x 0))
(let ((x 'A) (y 'B))
(swap! x y)
(==> x B)
(==> y A))
-37
View File
@@ -1,37 +0,0 @@
(let ((y "happy days")
(z #(1 2 3)))
(gc-flip)
(assert (string=? y "happy days"))
(assert (equal? z (vector 1 2 3))))
(let ((x 'HELLO)
(v #( HELLO ) ))
(display v)
(assert (eq? x (vector-ref v 0)))
(gc-flip)
(assert (eq? x (vector-ref v 0))))
(define counter 500)
(define big-vector '())
(define (basic-loop)
(begin
(set! big-vector (make-vector 200 0))
(set! counter (- counter 1))
(vector-fill! big-vector counter)
(gc-flip)
(assert (= (vector-ref big-vector 3) counter))
(if (> counter 0)
(basic-loop)
'())
) )
(basic-loop)
(==> (call/cc (lambda (throw) (define x '(1 2 3)) (gc-flip) (throw x))) (1 2 3))
(print-gc-statistics)
@@ -1,29 +0,0 @@
(define h (make-hash-table))
(assert (hash-table? h))
(hash-table-set! h 2000 1)
(assert (equal? (list (cons 2000 1)) (hash-table->alist h)))
(hash-table-set! h 2001 2)
(assert (equal? -1 (hash-table-ref h 3000 -1)))
(assert (equal? 1 (hash-table-ref h 2000 -1)))
(assert (equal? 2 (hash-table-ref h 2001 -1)))
(define h2 (alist->hash-table (hash-table->alist h)))
(assert (equal? -1 (hash-table-ref h2 3000 -1)))
(assert (equal? 1 (hash-table-ref h2 2000 -1)))
(assert (equal? 2 (hash-table-ref h2 2001 -1)))
(define h3 (alist->hash-table '((APPLE . "apple") (PEAR . "pear") (BANANA . "banana"))))
(assert (equal? "apple" (hash-table-ref h3 'APPLE)))
(assert (equal? "pear" (hash-table-ref h3 'PEAR)))
(assert (equal? '() (hash-table-ref h3 'HASH)))
@@ -1,160 +0,0 @@
; Scheme 9 from Empty Space, Function Library
; By Nils M Holm, 2009-2012
; Placed in the Public Domain
;
; (draw-tree object) ==> unspecific
; (dt) ==> unspecific
;
; Print a tree structure resembling a Scheme datum. Each cons
; cell is represented by [o|o] with lines leading to their car
; and cdr parts. Conses with a cdr value of () are represented
; by [o|/].
;
; DT is an abbrevation for DRAW-TREE.
;
; (Example): (draw-tree '((a) (b . c) (d e))) ==> unspecific
;
; Output: [o|o]---[o|o]---[o|/]
; | | |
; [o|/] | [o|o]---[o|/]
; | | | |
; a | d e
; |
; [o|o]--- c
; |
; b
(define (draw-tree n)
(define *nothing* (cons 'N '()))
(define *visited* (cons 'V '()))
(define (empty? x) (eq? x *nothing*))
(define (visited? x) (eq? (car x) *visited*))
(define (mark-visited x) (cons *visited* x))
(define (members-of x) (cdr x))
(define (done? x)
(and (pair? x)
(visited? x)
(null? (cdr x))))
(define (draw-fixed-string s)
(let* ((b (make-string 8 #\space))
(k (string-length s))
(s (if (> k 7) (substring s 0 7) s))
(s (if (< k 3) (string-append " " s) s))
(k (string-length s)))
(display (string-append s (substring b 0 (- 8 k))))))
(define (draw-atom n)
(cond ((null? n)
(draw-fixed-string "()"))
((symbol? n)
(draw-fixed-string (symbol->string n)))
((number? n)
(draw-fixed-string (number->string n)))
((string? n)
(draw-fixed-string (string-append "\"" n "\"")))
((char? n)
(draw-fixed-string (string-append "#\\" (string n))))
((eq? n #t)
(draw-fixed-string "#t"))
((eq? n #f)
(draw-fixed-string "#f"))
(else
(error "draw-atom: unknown type" n))))
(define (draw-conses n)
(let draw-conses ((n n)
(r '()))
(cond ((not (pair? n))
(draw-atom n)
(reverse! r))
((null? (cdr n))
(display "[o|/]")
(reverse! (cons (car n) r)))
(else
(display "[o|o]---")
(draw-conses (cdr n) (cons (car n) r))))))
(define (draw-bars n)
(let draw-bars ((n (members-of n)))
(cond ((not (pair? n)) '())
((empty? (car n))
(draw-fixed-string "")
(draw-bars (cdr n)))
((and (pair? (car n))
(visited? (car n)))
(draw-bars (members-of (car n)))
(draw-bars (cdr n)))
(else
(draw-fixed-string "|")
(draw-bars (cdr n))))))
(define (skip-empty n)
(if (and (pair? n)
(or (empty? (car n))
(done? (car n))))
(skip-empty (cdr n))
n))
(define (remove-trailing-nothing n)
(reverse (skip-empty (reverse n))))
(define (all-vertical? n)
(or (not (pair? n))
(and (null? (cdr n))
(all-vertical? (car n)))))
(define (draw-members n)
(let draw-members ((n (members-of n))
(r '()))
(cond ((not (pair? n))
(mark-visited
(remove-trailing-nothing
(reverse r))))
((empty? (car n))
(draw-fixed-string "")
(draw-members (cdr n)
(cons *nothing* r)))
((not (pair? (car n)))
(draw-atom (car n))
(draw-members (cdr n)
(cons *nothing* r)))
((null? (cdr n))
(draw-members (cdr n)
(cons (draw-final (car n)) r)))
((all-vertical? (car n))
(draw-fixed-string "[o|/]")
(draw-members (cdr n)
(cons (caar n) r)))
(else
(draw-fixed-string "|")
(draw-members (cdr n)
(cons (car n) r))))))
(define (draw-final n)
(cond ((not (pair? n))
(draw-atom n)
*nothing*)
((visited? n)
(draw-members n))
(else
(mark-visited (draw-conses n)))))
(if (not (pair? n))
(draw-atom n)
(let draw-tree ((n (mark-visited (draw-conses n))))
(if (not (done? n))
(begin (newline)
(draw-bars n)
(newline)
(draw-tree (draw-members n))))))
(newline))
(define dt draw-tree)
@@ -1,283 +0,0 @@
; Scheme 9 from Empty Space, Function Library
; By Nils M Holm, 1998-2009
; Placed in the Public Domain
;
; (prolog list1 list2) ==> list
; (new-database!) ==> unspecific
; (fact! list) ==> unspecific
; (predicate! list1 list2 ...) ==> unspecific
; (query list) ==> list
;
; (load-from-library "prolog.scm")
;
; This is a tiny PROLOG interpreter that is based on an even
; tinier PROLOG interpreter written in MACLISP by Ken Kahn.
;
; The PROLOG procedures takes a query LIST1 and a database
; LIST2 as arguments, attempts to prove LIST1 in LIST2, and
; returns the result(s).
; NEW-DATABASE! sets up a fresh PROLOG database (thereby
; deleting any existing one).
;
; FACT! adds a new fact to the database.
;
; PREDICATE! adds a predicate with the head LIST1 and the
; clauses LIST2 ... to the database.
;
; QUERY attempts to prove LIST1. It returns a list of results.
; An empty list indicates that LIST1 could not be proven.
;
; See "prolog-test.scm" for an example program.
;
; The following macros add some syntactic sugar for interactive
; use; they allows you to write, for instance, (! (man socrates))
; instead of (fact! '(man socrates)).
;
; (! fact) ==> unspecific
; (:- list1 list2 ...) ==> unspecific
; (? query) ==> unspecific
;
; The following special predicates are implemented in the
; interpreter: (== A B) returns a new environment if A can be
; unified with B, else NO. (Dif A B) returns NO if A can be
; unified with B, else YES (use only at the end of a clause!)
;
; Example: (begin (! (man socrates))
; (:- (mortal ?x)
; (man ?x))
; (query '(mortal ?who))) ==> (((who . socrates)))
(define *prolog-database* '())
(define (prolog q db)
(define empty-env '((())))
(define top-scope "")
(define true '(()))
(define false '())
(define (unique a)
(letrec
((unique2
(lambda (a r)
(cond ((null? a)
(reverse! r))
((member (car a) r)
(unique2 (cdr a) r))
(else
(unique2 (cdr a)
(cons (car a) r)))))))
(unique2 a '())))
(define (variable? x)
(and (symbol? x)
(char=? #\? (string-ref (symbol->string x) 0))))
(define (internal? x)
(and (symbol? x)
(char=? #\: (string-ref (symbol->string x) 0))))
(define (anonymous? x)
(eq? '_ x))
(define (extend n v env)
(cons (cons n v) env))
(define (new-scope env id)
(cond ((variable? env)
(string->symbol
(string-append (symbol->string env) id)))
((pair? env)
(cons (new-scope (car env) id)
(new-scope (cdr env) id)))
(else
env)))
(define (new-env-id x)
(string-append ";" x))
(define (value-of x env)
(if (variable? x)
(let ((v (assq x env)))
(if v
(value-of (cdr v) env)
x))
x))
(define (unify x y env)
(let ((x (value-of x env))
(y (value-of y env)))
(cond ((variable? x) (extend x y env))
((variable? y) (extend y x env))
((or (anonymous? x)
(anonymous? y))
env)
((and (pair? x)
(pair? y))
(let ((new (unify (car x) (car y) env)))
(and new (unify (cdr x) (cdr y) new))))
((eq? x y) env)
(else #f))))
(define (check-args g n)
(if (not (= n (length g)))
(error "wrong number of arguments" g)))
(define (goal-unify rules goals env id result)
(check-args (car goals) 3)
(let* ((this-goal (car goals))
(new-env (unify (cadr this-goal) (caddr this-goal) env)))
(if new-env
(let ((r (prove (cdr goals)
new-env
(new-env-id id))))
(try-rules (cdr rules) goals env id (append result r)))
(try-rules (cdr rules) goals env id result))))
(define (goal-dif rules goals env id result)
(check-args (car goals) 3)
(let* ((this-goal (car goals))
(new-env (unify (cadr this-goal) (caddr this-goal) env)))
(if (not new-env)
(let ((r (prove (cdr goals)
env
(new-env-id id))))
(try-rules (cdr rules) goals env id (append result r)))
false)))
(define (goal* rules goals env id result)
(let* ((this-rule (new-scope (car rules) id))
(new-env (unify (car goals) (car this-rule) env)))
(if new-env
(let ((r (prove (append (cdr this-rule) (cdr goals))
new-env
(new-env-id id))))
(try-rules (cdr rules) goals env id (append result r)))
(try-rules (cdr rules) goals env id result))))
(define (try-rules rules goals env id result)
(if (null? rules)
result
(case (caar goals)
((==) (goal-unify rules goals env id result))
((dif) (goal-dif rules goals env id result))
(else (goal* rules goals env id result)))))
(define (list-env env)
(letrec
((this-id caar)
(scope-id caddr)
(top-level?
(lambda (x)
(not (memv #\; (string->list (symbol->string x))))))
(var-name
(lambda (x)
(let* ((s (symbol->string x))
(k (string-length s)))
(let loop ((i 0))
(if (or (>= i k)
(char=? #\; (string-ref s i)))
(string->symbol (substring s 1 i))
(loop (+ 1 i)))))))
(list-env2
(lambda (e r)
(cond ((null? (cdr e))
(list r))
((top-level? (this-id e))
(list-env2 (cdr e)
(extend (var-name (this-id e))
(value-of (this-id e) env)
r)))
(else
(list-env2 (cdr e) r))))))
(list-env2 env '())))
; version without memoization
(define (prove goals env id)
(if (null? goals)
(list-env env)
(try-rules db goals env id '())))
;(define proven (make-hash-table))
;(define (prove goals env id)
; (if (null? goals)
; (list-env env)
; (let* ((k (append goals env))
; (v (hash-table-ref proven k #f)))
; (if v
; (car v)
; (let ((v (try-rules db goals env id '())))
; (hash-table-set! proven k v)
; v)))))
(define (any? p a)
(cond ((null? a) #f)
((p (car a)) #t)
(else (any? p (cdr a)))))
(define (cleanup env)
(apply append
(map (lambda (frame)
(if (or (any? (lambda (x) (variable? (cdr x))) frame)
(any? (lambda (x) (internal? (cdr x))) frame))
'()
(list frame)))
env)))
(cleanup (unique (prove (new-scope q top-scope)
empty-env
(new-env-id top-scope)))))
(define (new-database!)
(set! *prolog-database* '()))
(define (update! x)
(set! *prolog-database*
(cons x *prolog-database*)))
(define (fact! x)
(let ((update! update!))
(update! (list x))))
(define (predicate! head . clause*)
(let ((update! update!))
(update! (cons head clause*))))
(define (query . q)
(prolog q (reverse *prolog-database*)))
(define (print-frames env)
(cond ((equal? '(()) env)
(display "yes")
(newline))
((equal? '() env)
(display "no")
(newline))
(else
(for-each (lambda (frame)
(for-each (lambda (b)
(display (car b))
(display " = ")
(display (cdr b))
(display "; "))
frame)
(newline))
env))))
(define-macro ! (lambda (fact) `(fact! (quote ,fact))))
(define-macro :- (lambda args
(cons 'PREDICATE! (map1 (lambda (entry) `(quote ,entry)) args))))
(define-macro ? (lambda args
(list 'PRINT-FRAMES
(cons 'QUERY (map1 (lambda (entry) `(quote ,entry)) args)))))
-69
View File
@@ -1,69 +0,0 @@
(assert '())
(==> (cons 'a (cons 'b (cons 'c '()))) (a b c))
(==> (car (cons 1 2)) 1)
(==> (cdr (cons 1 2)) 2)
(==> (car (list 1 2)) 1)
(==> (cdr (list 1 2)) (2))
(define test-pair (cons 1 2))
(set-car! test-pair 3)
(set-cdr! test-pair 4)
(==> test-pair (3 . 4))
(==> (reverse '(a b c)) (c b a))
; https://groups.csail.mit.edu/mac/ftpdir/scheme-7.4/doc-html/scheme_8.html
(assert (pair? '(a . b)))
(assert (pair? '(a b c)))
(assert (not (pair? '())))
(assert (not (pair? '#(a b))))
(assert (= (length '(a b c)) 3))
(assert (= (length '()) 0))
(assert (not (null? '(a b c))))
(assert (null? '()))
(assert (eq? (list-ref '(a b c d) 2) 'c))
(==> (append '(a) '(b c d)) (a b c d))
(==> (sort '(1 4 2 6 3) <) (1 2 3 4 6))
(==> (make-list 4 1) (1 1 1 1))
(==> (memq 'a '(a b c)) (a b c))
(==> (memq 'b '(a b c)) (b c))
(==> (memq 'a '(b c d)) #f)
(==> (member (list 'a) '(b (a) c)) ((a) c))
(==> (member 'a '(b (a) c)) #f)
(assert (= (apply + (list 3 4 5 6)) 18))
(==> (append-reverse! '("y" "x" "w") '("z")) ("w" "x" "y" "z"))
; Association lists
(define list-map '((bob . 1) (john . 2) (dan . 3) (alice . 4)))
(assert (= (cdr (assoc 'john list-map)) 2))
(assert (= (cdr (assoc 'alice list-map)) 4))
(assert (not (assoc 'bad-key list-map)))
(assert (= (cdr (assq 'john list-map)) 2))
(assert (= (cdr (assq 'alice list-map)) 4))
(assert (not (assq 'bad-key list-map)))
(assert (list? '(1 2)))
(assert (not (list? (cons 1 2))))
(==> (reduce + 0 '(1 2 3 4)) 10)
(==> (reduce + 0 '(1 2)) 3)
(==> (reduce + 0 '()) 0)
(==> (reduce list '() '(1 2 3 4)) (((1 2) 3) 4))
(==> (fold-left + 0 '(1 2 3 4)) 10)
(==> (fold-left list '() '(1 2 3 4)) ((((() 1) 2) 3) 4))
-33
View File
@@ -1,33 +0,0 @@
; QUASIQUOTE
(assert (equal? `(1 2 3) '(1 2 3)))
(let ((x 1))
(assert (equal? `(,x 2 3) '(1 2 3))))
(let ((x 'a))
(assert (equal? `(,x x ,x) '(a x a))))
; nil! macro
(define-macro nil! (lambda (x)
`(set! ,x '())))
(define x 3)
(assert (= x 3))
(nil! x)
(assert (null? x))
; ntimes macro
(define-macro ntimes (lambda (n . body)
(let ((i (gensym)))
(cons 'DO (cons `((,i 0 (+ ,i 1)))
(cons `((>= ,i ,n) '()) body))
))))
(define x 0)
(ntimes 10 (set! x (+ x 1)))
(assert (= x 10))
-71
View File
@@ -1,71 +0,0 @@
; From Peter Norvig's Lispy tests
; http://norvig.com/lispy2.html
(define x 3)
(assert (= x 3))
(assert (= (+ x x) 6))
(assert (= (begin (define x 1) (set! x (+ x 1)) (+ x 1)) 3))
(assert (= ((lambda (x) (+ x x)) 5) 10))
(define twice (lambda (x) (* 2 x)))
(assert (= (twice 5) 10))
(define compose (lambda (f g) (lambda (x) (f (g x)))))
(assert (= (car ((compose list twice) 5)) 10))
(define repeat (lambda (f) (compose f f)))
(assert (= ((repeat twice) 5) 20))
(assert (= ((repeat (repeat twice)) 5) 80))
(define fact (lambda (n) (if (< n 2) 1 (* n (fact (- n 1))))))
(assert (= (fact 3) 6))
(define abs (lambda (n) ((if (> n 0) + -) 0 n)))
(assert (= (car (list (abs -3) (abs 0) (abs 3))) 3))
(define combine (lambda (f)
(lambda (x y)
(if (null? x) (quote ())
(f (list (car x) (car y))
((combine f) (cdr x) (cdr y)))))))
(define zip (combine cons))
(assert (= (car (cdr (assoc 3 (zip (list 1 2 3 4) (list 5 6 7 8))))) 7))
(define riff-shuffle (lambda (deck) (begin
(define take (lambda (n seq) (if (< n 1) (quote ()) (cons (car seq) (take (- n 1) (cdr seq))))))
(define drop (lambda (n seq) (if (< n 1) seq (drop (- n 1) (cdr seq)))))
(define mid (lambda (seq) (/ (length seq) 2)))
((combine append) (take (mid deck) deck) (drop (mid deck) deck)))))
(display (riff-shuffle (list 1 2 3 4 5 6 7 8)))
(newline)
(display ((repeat riff-shuffle) (list 1 2 3 4 5 6 7 8)))
(newline)
(display (riff-shuffle (riff-shuffle (riff-shuffle (list 1 2 3 4 5 6 7 8)))))
(newline)
(define fabs (lambda (n) ((if (> n 0.0) + -) 0.0 n)))
(define (newton guess function derivative epsilon)
(define guess2 (- guess (/ (function guess) (derivative guess))))
(if (< (fabs (- guess guess2)) epsilon) guess2
(newton guess2 function derivative epsilon)))
(define (square-root a)
(newton 1.0 (lambda (x) (- (* x x) a)) (lambda (x) (* 2.0 x)) 0.0001))
(display "sqrt(2)=")
(display (square-root 2.0))
(newline)
(display "sqrt(200)=")
(display (square-root 200.0))
(newline)
(==> (call/cc (lambda (throw) (+ 5 (* 10 (throw 1))))) 1)
(==> (call/cc (lambda (throw) (+ 5 (* 10 1)))) 15)
(==> (call/cc (lambda (throw) (+ 5 (* 10 (call/cc (lambda (escape) (* 100 (escape 3)))))))) 35)
(==> (call/cc (lambda (throw) (+ 5 (* 10 (call/cc (lambda (escape) (* 100 (throw 3)))))))) 3)
(==> (call/cc (lambda (throw) (+ 5 (* 10 (call/cc (lambda (escape) (* 100 1))))))) 1005)
(==> (let ((a 1) (b 2)) (+ a b)) 3)
-82
View File
@@ -1,82 +0,0 @@
(==> (+ 2 2) 4)
(==> (+ (* 2 100) (* 1 10)) 210)
(==> (if (> 6 5) (+ 1 1) (+ 2 2)) 2)
(==> (if (< 6 5) (+ 1 1) (+ 2 2)) 4)
(==> (gcd 32 -36) 4)
(==> (gcd 4 3) 1)
(==> (gcd) 0)
(==> (lcm 32 -36) 288)
(assert (exact? (lcm 32 -36)))
(assert (inexact? (lcm 32.0 -36)))
(==> (lcm) 1)
(==> (abs -1) 1)
(==> (map + '(1 1 1) '(2 2 2)) (3 3 3))
(==> (map abs '(-1 -2 3)) (1 2 3))
(==> (vector-map abs #(-1 -2 3)) #(1 2 3))
(==> (- 1) -1)
(==> (- 436) -436)
(==> (- -7) 7)
(assert (integer? 3))
(assert (real? 3))
(assert (real? 3.5))
(assert (not (integer? 3.5)))
(assert (< 3 4))
(assert (> 4 3))
(assert (>= 4 3))
(assert (<= 3 4))
(assert (<= 1 1))
(assert (< -5 5))
(assert (not (> 3 4)))
(assert (= (modulo -13 4) 3))
(assert (= (remainder -13 4) -1))
(assert (= (remainder 13 -4) 1))
(assert (even? 2))
(assert (not (odd? 2)))
(assert (odd? 3))
(assert (odd? 7))
(assert (not (odd? 4)))
(assert (exact? (+ 1 2 3)))
(assert (inexact? (+ 1 2.5 3)))
(assert (inexact? (+ 1.3 2 3)))
(assert (exact? (* 1 2 3)))
(assert (inexact? (* 1 2.5 3)))
(assert (inexact? (* 1.3 2 3)))
(assert (exact? (- 1 2)))
(assert (inexact? (- 1 2.5)))
(assert (inexact? (- 1.3 2)))
(assert (exact? (expt 3 3)))
(==> (expt 3 3) 27)
(assert (inexact? (expt 3 2.5)))
(==> (magnitude 13) 13)
(==> (magnitude -13) 13)
(==> (floor 0.87) 0)
(==> (ceiling 0.87) 1)
(==> (round 0.87) 1)
(assert (< (- (abs (atan 0)) (/ 3.141592 4)) 0.001))
-21
View File
@@ -1,21 +0,0 @@
(define (brute max-length set)
(define (permute n)
(define str (make-string n))
(define (iter d)
(if (= d n)
(begin
(display str)
(display " "))
(do ((i 0 (+ i 1)))
((= i (string-length set)) 'done)
(begin
(string-set! str d (string-ref set i))
(iter (+ d 1))))))
(iter 0))
(do ((len 0 (+ len 1)))
((> len max-length) 'done)
(permute len)))
(brute 4 "abcd")
(newline)
-5
View File
@@ -1,5 +0,0 @@
(include "include/prolog.scm")
(! (man socrates))
(:- (mortal ?x) (man ?x))
(? (mortal ?who))
-158
View File
@@ -1,158 +0,0 @@
; A collection of SICP excercises
; these are all my solutions from reading
; the book
; 1.01 - basic expressions
(assert (= (+ (* 2 4) (- 4 6)) 6))
(define a 3)
(define b (+ a 1))
(assert (= (+ a b (* a b)) 19))
(assert (= (if (and (> b a) (< b (* a b)))
b
a) 4))
(assert (= (cond ((= a 4) 6)
((= b 4) (+ 6 7 a))
(else 25)) 16))
(assert (= (+ 2 (if (> b a) b a )) 6))
(assert (= (* (cond ((> a b) a)
((< a b) b)
(else -1))
(+ a 1)) 16))
; 1.03 - largest squares
(define (sqr x) (* x x))
(define (largest-squares x y z)
(cond ((and (< z x) (< z y)) (+ (sqr x) (sqr y)))
((and (< y x) (> y z)) (+ (sqr x) (sqr z)))
(else (+ (sqr y) (sqr z)))
))
(assert (= (largest-squares 3 4 5) (+ 25 16)))
(assert (= (largest-squares 3 5 4) (+ 25 16)))
; 1.14 change counter
(define (count-change amount) (cc amount 5))
(define (cc amount kinds-of-coins)
(cond ((= amount 0) 1)
((or (< amount 0) (= kinds-of-coins 0)) 0)
(else (+ (cc amount
(- kinds-of-coins 1))
(cc (- amount
(first-denomination kinds-of-coins))
kinds-of-coins)))))
(define (first-denomination kinds-of-coins)
(cond ((= kinds-of-coins 1) 1)
((= kinds-of-coins 2) 5)
((= kinds-of-coins 3) 10)
((= kinds-of-coins 4) 25)
((= kinds-of-coins 5) 50)))
(display "counting change: ")
(display (count-change 75))
(newline)
; 1.16 - fast powers
(define (exp-fast b n) (exp-iter b n 1))
(define (exp-iter b n product)
(cond ((= n 0) product)
; b^n = (b^2) n/2
((even? n) (exp-iter (* b b) (/ n 2) product))
; b^n = b * b^n-1
(else (exp-iter b (- n 1) (* product b)))))
(assert (= (exp-fast 5 4) 625))
(assert (= (exp-fast 2 8) 256))
; 1.17 - fast multiply
(define (double a) (+ a a))
(define (halve a) (/ a 2))
(define (fast-mul a b) (fast-mul-iter a b 0))
(define (fast-mul-iter a b sum)
(cond ((= b 0) sum)
((even? b) (fast-mul-iter (double a) (halve b) sum))
(else (fast-mul-iter a (- b 1) (+ sum a)))))
(assert (= (fast-mul 3 4) 12))
(assert (= (fast-mul 100 10) 1000))
; 1.19 fibonacci
(define (fib-helper n a b p q)
(cond
((= n 0) b)
((even? n) (fib-helper (/ n 2)
a
b
(+ (* p p) (* q q))
(+ (* 2 q p) (* q q ))
))
(else
(fib-helper
(- n 1)
(+ (* b q) (* a q) (* a p))
(+ (* b p) (* a q))
p
q))))
(define (fib n)
(fib-helper n 1 0 0 1))
(assert (= (fib 5) 5))
(assert (= (fib 7) 13))
(assert (= (fib 8) 21))
; 2.21 - square list
(define (square-list items)
(if (null? items)
items
(cons (* (car items) (car items)) (square-list (cdr items)))))
(define (square-list2 items)
(map (lambda (x) (* x x)) items))
(display (square-list (list 1 2 3 4)))
(newline)
(display (square-list2 (list 4 5 6 7)))
; bank accounts
(define (make-account val)
(lambda (action)
(if (eq? action 'deposit)
(lambda (n) (set! val (+ val n)))
(lambda (n) (set! val (- val n))))))
(define justin (make-account 100))
(define ryan (make-account 200))
((justin 'deposit) 20)
((ryan 'withdraw) 20)
(gc-flip)
(assert (= ((justin 'withdraw) 0) 120))
(assert (= ((ryan 'deposity) 0) 180))
; and or expansion
(let ((a 1))
(if (and (= a 0) (garbage here))
(assert 0)
'pass)
(if (or (= a 1) (garbage here))
'pass
(assert 0)))
-32
View File
@@ -1,32 +0,0 @@
(==> (force (delay (+ 1 2))) 3)
(==> (let ((p (delay (+ 1 2))))
(list (force p) (force p))) (3 3))
(assert (promise? (delay (+ 1 2))))
; promises computed at most once
(define count 0)
(define p
(delay
(begin
(set! count (+ count 1))
(* x 3))))
(define x 5)
(==> count 0)
(assert (promise? p))
(==> (force p) 15)
(assert (promise? p))
(==> count 1)
(==> (force p) 15)
(==> count 1)
(define (integers-starting-from n)
(cons-stream n (integers-starting-from (+ n 1))))
(assert (equal? (stream-head (integers-starting-from 0) 5) '(0 1 2 3 4)))
-60
View File
@@ -1,60 +0,0 @@
; https://groups.csail.mit.edu/mac/ftpdir/scheme-7.4/doc-html/scheme_7.html
; TODO: add characters to reader
(==> (make-string 10 #\x) "xxxxxxxxxx")
(assert (string? "Hi"))
(assert (not (string? 'Hi)))
(==> (string-length "") 0)
(==> (string-length "The length") 10)
(assert (string=? "PIE" "PIE"))
(assert (not (string=? "PIE" "pie")))
(==> (list->string (string->list "hello 123")) "hello 123")
(==> (string->list (list->string '(#\A #\B #\3))) (#\A #\B #\3))
; https://www.gnu.org/software/mit-scheme/documentation/mit-scheme-ref/Symbols.html
(assert (symbol? 'foo))
(assert (symbol? (car '(a b))))
(assert (not (symbol? "bar")))
(assert (eq? 'foo (string->symbol "FOO")))
(assert (string=? "FLYING-FISH" (symbol->string 'flying-fish)))
; specials
(==> (string-length "\\") 1)
(==> (string-length "\t") 1)
(==> (string-length "\n") 1)
(==> (string-length "\f") 1)
(==> (string-length "\"") 1)
(display "Hello\nworld!")
(==> (string->number (number->string 279)) 279)
(==> (number->string (string->number "279")) "279")
(==> (string->number (number->string 0.5)) 0.5)
(assert (symbol<? 'A 'B))
(assert (not (symbol<? 'WALK 'DOG)))
(==> (- (char->integer #\c) (char->integer #\a)) 2)
(==> (string-ref "abc" 0) #\a)
(==> (string-ref "abc" 2) #\c)
(==> (string #\a #\b) "ab")
(==> (string) "")
(assert (char<? #\a #\b))
(assert (char<=? #\a #\a))
(assert (char-lower-case? #\a))
(assert (not (char-lower-case? #\A)))
(assert (not (char-upper-case? #\c)))
(assert (char-upper-case? #\C))
(assert (char-ci=? #\a #\A))
(assert (char-ci<? #\A #\b))
-75
View File
@@ -1,75 +0,0 @@
(define v #(1 2 3))
(vector-swap! v 0 2)
(assert (= 3 (vector-ref v 0)))
(assert (= 1 (vector-ref v 2)))
(define (vec-sorted? v op)
; "if x and y are any two adjacent elements in the result,
; where x precedes y, it is the case that (procedure y x) ==> #f"
; https://groups.csail.mit.edu/mac/ftpdir/scheme-7.4/doc-html/scheme_8.html#SEC72
(or (< (vector-length v) 2)
(and (not (op (vector-ref v 1) (vector-ref v 0)))
(vec-sorted? (vector-tail v 1) op))))
; First make sure our sorted checker works
(assert (vec-sorted? #(1 2 2 4 5 6) <))
(assert (vec-sorted? #(1) <))
(assert (vec-sorted? #(1 2) <))
(assert (vec-sorted? #(7 6 5 4 3 2 1) >))
(assert (not (vec-sorted? #(2 1) <)))
(assert (not (vec-sorted? #(1 2 3 4 4 3) <)))
(assert (not (vec-sorted? #(1 2 3 2 4 5) <)))
; Now test the sort function
(assert (vec-sorted? (sort! #(1) <) <))
(assert (vec-sorted? (sort! #(2 1) <) <))
(assert (vec-sorted? (sort! #(1 2 3) <) <))
(assert (vec-sorted? (sort! #(3 8 1 7 2 9 4 5) <) <))
(assert (vec-sorted? (sort! #(1 2 3 4 5 6 7 8) <) <))
(assert (vec-sorted? (sort! #(3 8 1 7 2 9 4 5) >) >))
(assert (vec-sorted? (sort! #(1 2 3 4 5 6 7 8) >) >))
(assert (vec-sorted? (sort! #(92 59 30 57 74 78 43 33 77 10 78 83 76 49 42 94 82 70 15 11 90 86 44 70 39 64 69 30 59 95 15 79 13 54 98 82 42 96 79 17 56 93 20 1 84 72 75 19 74 43) >) >))
(assert (vec-sorted? (sort! #(92 59 30 57 74 78 43 33 77 10 78 83 76 49 42 94 82 70 15 11 90 86 44 70 39 64 69 30 59 95 15 79 13 54 98 82 42 96 79 17 56 93 20 1 84 72 75 19 74 43) <) <))
(assert (vec-sorted? (sort! #(3 8 1 7 2 9 4 5) <) <))
; Try other data types
(assert (vec-sorted? (sort! #(#\C #\B #\A #\D) char<?) char<?))
; Converting between lists and vectors
;https://www.gnu.org/software/mit-scheme/documentation/stable/mit-scheme-ref/Construction-of-Vectors.html
(==> (vector 'a 'b 'c) #(A B C))
(==> (list->vector '(dididit dah)) #(dididit dah))
; Binary search
(assert (= (vector-binary-search #(1 2 3 4 5) < (lambda (x) x) 3) 3))
(assert (not (vector-binary-search #(1 2 2 4 5) < (lambda (x) x) 3)))
(define v (vector 1 1 2))
(vector-fill! v 3)
(==> v #(3 3 3))
(==> (make-initialized-vector 5 (lambda (x) (* x x))) #(0 1 4 9 16))
(==> (vector-head #(1 2 3) 2) #(1 2))
; Issues parsing large vector
(define big-v #(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200))
(==> (vector-length big-v) 200)
; Subvector
(==> (subvector #(1 2 3 4) 1 4) #(2 3 4))
(==> (subvector #(1 2 3 4) 0 2) #(1 2))
(==> (subvector #(A 1 A 1 A 1 A 1) 1 3) #(1 A))
; Association
(define avector #((bob . 1) (john . 2) (dan . 3) (alice . 4)))
(assert (= (cdr (vector-assq 'john avector)) 2))
(assert (= (cdr (vector-assq 'alice avector)) 4))
(assert (not (vector-assq 'bad-key avector)))
(sort! (make-initialized-vector 10000 (lambda (x) (random 1000000))) <)
-20
View File
@@ -1,20 +0,0 @@
; try this one with read
(let* ((file (open-input-file "big_data_gen.sexpr"))
(data (read file)))
(gc-flip)
(print-gc-statistics)
(newline)
(display "records: ")
(display (length data))
(newline)
(let ((record (car data)))
(assert (= (cdr (vector-assq 'index record)) 0))
(assert (eq? (cdr (vector-assq 'isActive record)) 'False))
(assert (= (cdr (vector-assq 'age record)) 21)))
(close-input-port file))
(display "done")
(newline)
-12
View File
@@ -1,12 +0,0 @@
; canada
(let ((data (read)))
(gc-flip)
(print-gc-statistics)
(newline)
(display "records: ")
(display (vector-length data)))
(gc-flip)
(print-gc-statistics)
File diff suppressed because one or more lines are too long
File diff suppressed because one or more lines are too long
File diff suppressed because it is too large Load Diff
File diff suppressed because one or more lines are too long
@@ -1,38 +0,0 @@
import json
import sys
import itertools
json_data = json.load(sys.stdin)
def lisp_dump(data):
if isinstance(data, int):
return str(data)
elif isinstance(data, float):
return str(data)
elif isinstance(data, str):
escaped_string = data.encode("unicode_escape").decode("utf-8")
return "\"" + escaped_string + "\""
elif isinstance(data, list):
result = "("
for i, item in enumerate(data):
result += lisp_dump(item)
if i + 1 < len(data):
result += " "
result += ")"
return result
elif isinstance(data, dict):
result = "#("
i = 0
for key, item in data.items():
result += "(%s . %s)" % (key, lisp_dump(item))
if i + 1 < len(data):
result += " "
i += 1
result += ")"
return result
else:
print("error")
print(type(data))
print(lisp_dump(json_data))
-4
View File
@@ -1,4 +0,0 @@
#!/bin/sh
../../lisp --script big_data1.scm
cat big_data_canada.sexpr | ../../lisp --script big_data2.scm
@@ -1,81 +0,0 @@
(define (quasiquote-helper tail x)
(cond ((null? x) (reverse! tail))
((not (pair? x)) (list 'QUOTE x))
((eq? 'UNQUOTE (car x)) (car (cdr x)))
((eq? 'UNQUOTESPLICE (car x)) (error "invalid place"))
((and (pair? (car x))
(eq? (car (car x)) 'UNQUOTESPLICE))
(quasiquote-helper (reverse-append! (car (cdr (car x))) tail) (cdr x))
)
(else
(quasiquote-helper (cons (quasiquote-helper '() (car x)) tail)
(cdr x)))
))
(define-macro quasiquote
(lambda (x)
(display x)
(newline)
(quasiquote-helper '() x)
))
(display (macroexpand '`(1 ,x 3)))
(newline)
;(display (macroexpand '`(1 ,@(2 2) 3)))
(define-macro do2
(lambda (vars loop-check loop)
(let ((names '())
(inits '())
(steps '())
(func (gensym)))
(for-each (lambda (var)
(push (car var) names)
(set! var (cdr var))
(push (car var) inits)
(set! var (cdr var))
(push (car var) steps))
vars)
(display loop-check)
(newline)
`((lambda (,func)
(begin
(set! ,func (lambda ,names
(if ,(car loop-check)
,(car (cdr loop-check))
,(cons 'BEGIN (list loop (cons func steps)))
)))
,(cons func inits)
)) '())
)))
(display (macroexpand '(do2 ((i 0 (+ i 1)))
((> i 0) 'done)
'())))
(newline)
(newline)
(define-macro let2 (lambda (def-list . body)
(cons `(lambda
,(map1 (lambda (entry) (car entry)) def-list '())
,(cons 'BEGIN body))
(map1 (lambda (entry) (car (cdr entry))) def-list '())) ))
(display (macroexpand
'(let2 ((x 1) (y 2)) (set! x (+ x y)) x)))
@@ -1,2 +0,0 @@
temp1.scm
temp2.scm
-19
View File
@@ -1,19 +0,0 @@
(book
(author "ARISTOTLE")
(title "Categories")
(year -350)
(tags #(philosophy logic definitions substance))
(lines
"Things are said to be named \"equivocally\" when, though they have a common name, the definition corresponding with the name differs for each."
"Thus, a real man and a figure in a picture can both lay claim to the name \"animal\"; yet these are equivocally so named, for, though they have a common name, the definition corresponding with the name differs for each"
"For should any one define in what sense each is an animal, his definition in the one case will be appropriate to that case only.\n"
"On the other hand, things are said to be named \"univocally\" which have both the name and the definition answering to the name in common"
"A man and an ox are both \"animal\", and these are univocally so named, inasmuch as not only the name, but also the definition, is the same in both cases:"
"for if a man should state in what sense each is an animal, the statement in the one case would be identical with that in the other.\n"
"Things are said to be named \"derivatively\", which derive their name from some other name, but differ from it in termination."
"Thus the grammarian derives his name from the word \"grammar\", and the courageous man from the word \"courage\"."
))
(alphabet #\a #\b #\c #\d #\e)
(nums 0.0 0.25 0.5 0.75 1.0)
-14
View File
@@ -1,14 +0,0 @@
#!/bin/sh
# make sure reader and writer work and are compatible.
# 1. load s expresion, print it out.
cat sample.scm | ../../printer > temp1.scm
# 2. load the output, print it out again.
cat temp1.scm | ../../printer > temp2.scm
# 3. ensure both outputs match
cmp temp1.scm temp2.scm
+11 -2
View File
@@ -5,6 +5,9 @@
* interactions. \version 0.1 \date 21 septembre 2024
*/
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <unistd.h>
#define _DEFAULT_SOURCE
@@ -22,16 +25,22 @@ struct editorConfig E;
int main(int argc, char *argv[]) {
char * splash_screen = (char *) calloc(256, sizeof(char));
enableRawMode();
initEditor();
if (argc >= 2) {
E.state = READ_AND_WRITE;
editorOpen(argv[1]);
} else {
editorOpen("assets/beluga.txt");
strcat(splash_screen, getenv("HOME"));
strcat(splash_screen, "/.beluga/assets/beluga.txt");
fprintf(stderr, "%s\n", splash_screen);
editorOpen(splash_screen);
}
free(splash_screen);
editorSetStatusMessage("HELP: Ctrl-S = save | Ctrl-Q = quit");
editorSetStatusMessage("HELP: Ctrl-x Ctrl-s = save | Ctrl-x Ctrl-q = quit");
while (1) {
+1 -4
View File
@@ -8,14 +8,12 @@ project('beluga', 'c',
cc = meson.get_compiler('c')
m = cc.find_library('m', required: false)
# Include directory
inc_dir = include_directories('include', 'lisp-interpreter/dist')
# Source files
src_files = files(
'main.c',
'src/append_buffer.c',
'src/editor_op.c',
'src/syntax_highlighter.c',
'src/file_io.c',
'src/init.c',
'src/input.c',
@@ -28,6 +26,5 @@ src_files = files(
# Executable
executable('beluga',
src_files,
include_directories : inc_dir,
dependencies: [m]
)
+354 -36
View File
@@ -1,108 +1,272 @@
/**
* @file builtins.c
* @brief Built-in Lisp functions for editor operations
* @details Provides Lisp bindings for core editor functionality including
* cursor movement, file operations, keybinding management, and text manipulation
*/
#include "../include/builtins.h"
#include "../include/define.h"
#include "../include/input.h"
#include "../include/file_io.h"
#include "../include/editor_op.h"
#include "../include/data.h"
#include "../include/define.h"
#include "../include/editor_op.h"
#include "../include/file_io.h"
#include "../include/input.h"
#include "../include/row_op.h"
#include "include/output.h"
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
/**
* @brief Finds a prefix configuration by name
* @details Searches the prefix array for a prefix matching the given name.
* Returns the first prefix (default) if no match is found.
* @param prefix_name Name of the prefix to search for (max 64 chars)
* @return Matching prefix_t structure, or E.prefix[0] if not found
* @note Updates global editor state E
*/
struct prefix_t find_prefix(const char prefix_name[64]) {
int i = E.number_of_prefix + 1;
while (i--) {
if (!strcmp(prefix_name, E.prefix[i].prefix_name)) {
return E.prefix[i];
}
}
return E.prefix[0];
}
/**
* @brief Lisp function to bind a command to a key sequence
* @details Registers a keybinding with an associated Lisp command and optional
* prefix modifier. Dynamically extends the keybind array.
* @param args Lisp list of 3 arguments: (key-sequence command prefix-name)
* - key_sequence (string): The key or key combination to bind
* - command (Lisp): The Lisp command/function to execute
* - prefix_name (string): Prefix modifier name
* @param e Error pointer for Lisp error handling
* @param ctx Lisp context
* @return lisp_null()
* @note Updates global editor state E (key_binds array)
*/
Lisp mapKey(Lisp args, LispError *e, LispContext ctx) {
/*
* 3 arguments keybind command prefix
*/
const char *key_sequence = lisp_string(lisp_car(args));
args = lisp_cdr(args);
// second argument
Lisp func = lisp_car(args);
E.key_binds =
(struct keyBind_t *)realloc(E.key_binds, ++E.number_of_keybinds * sizeof(struct keyBind_t));
E.key_binds[E.number_of_keybinds - 1].key_sequence = (char *) malloc(50 * sizeof(char));
E.key_binds = (struct keyBind_t *)realloc(
E.key_binds, ++E.number_of_keybinds * sizeof(struct keyBind_t));
E.key_binds[E.number_of_keybinds - 1].key_sequence =
(char *)malloc(50 * sizeof(char));
strncpy(E.key_binds[E.number_of_keybinds - 1].key_sequence, key_sequence, 50);
E.key_binds[E.number_of_keybinds - 1].command = func;
// Third argument
args = lisp_cdr(args);
const char *prefix_name = lisp_string(lisp_car(args));
struct prefix_t prefix = find_prefix(prefix_name);
E.key_binds[E.number_of_keybinds - 1].prefix_id = prefix.prefix_id;
return lisp_null();
}
/**
* @brief Lisp function to move cursor in a specified direction
* @details Moves the editor cursor up, down, left, or right based on direction string.
* @param args Lisp list with one argument: direction string
* - "u": up, "d": down, "r": right, "l": left
* @param e Error pointer for Lisp error handling
* @param ctx Lisp context
* @return Lisp boolean indicating whether movement was valid
* @note Updates global editor state E
* @see editorMoveCursor()
*/
Lisp moveCursor(Lisp args, LispError *e, LispContext ctx) {
fprintf(stderr, "Cursor is moving\n");
const char *direction = lisp_string(lisp_car(args));
int is_in = 0;
switch (direction[0]) {
case 'u':
editorMoveCursor(ARROW_UP);
is_in = editorMoveCursor(ARROW_UP);
break;
case 'd':
editorMoveCursor(ARROW_DOWN);
is_in = editorMoveCursor(ARROW_DOWN);
break;
case 'r':
editorMoveCursor(ARROW_RIGHT);
is_in = editorMoveCursor(ARROW_RIGHT);
break;
case 'l':
editorMoveCursor(ARROW_LEFT);
is_in = editorMoveCursor(ARROW_LEFT);
break;
}
return lisp_null();
fprintf(stderr, "move lisp %d\n", is_in);
return lisp_make_bool(is_in);
}
Lisp editorQuit(Lisp args, LispError* e, LispContext ctx) {
/**
* @brief Frees all dynamically allocated editor structures
* @details Releases memory for prefix table, keybinds, filename, and all rows.
* Called during shutdown to prevent memory leaks.
* @note Updates global editor state E
*/
void free_structs(void) {
int i;
free(E.prefix);
for (i = 0; i < E.number_of_keybinds; ++i) {
free(E.key_binds[i].key_sequence);
}
free(E.key_binds);
free(E.filename);
for (i = 0; i < E.numrows; ++i) {
free(E.row[i].render);
free(E.row[i].chars);
}
free(E.row);
free(E.init_file_path);
fclose(E.fd_init_file);
}
/**
* @brief Lisp function to quit the editor
* @details Closes editor with unsaved changes protection. Prompts user to confirm
* quit after multiple attempts if file is dirty. Cleans up resources and restores terminal.
* @param args Lisp arguments (unused)
* @param e Error pointer for Lisp error handling
* @param ctx Lisp context
* @return lisp_null() (never returns on successful exit)
* @note Calls exit(0) to terminate program
* @note Updates quit_times_buffer counter
* @see free_structs()
*/
Lisp editorQuit(Lisp args, LispError *e, LispContext ctx) {
if (E.dirty && E.quit_times_buffer > 0) {
editorSetStatusMessage("WARNING! Changes hasn't been saved. Press Ctrl-Q "
"another time to quit.");
--E.quit_times_buffer;
return lisp_null();
}
free_structs();
write(STDOUT_FILENO, "\x1b[2J", 4);
write(STDOUT_FILENO, CURSOR_TOP_LEFT, 3);
disableRawMode();
lisp_shutdown(E.ctx);
exit(0);
return lisp_null();
}
Lisp l_editorSave(Lisp args, LispError* e, LispContext ctx) {
/**
* @brief Lisp function to save the current file
* @details Wrapper around editorSave() for use in Lisp keybindings.
* @param args Lisp arguments (unused)
* @param e Error pointer for Lisp error handling
* @param ctx Lisp context
* @return lisp_null()
* @see editorSave()
*/
Lisp l_editorSave(Lisp args, LispError *e, LispContext ctx) {
editorSave();
return lisp_null();
return lisp_null();
}
Lisp l_editorInsertNewLine(Lisp args, LispError* e, LispContext ctx) {
/**
* @brief Lisp function to insert a new line at cursor
* @details Wrapper around editorInsertNewLine() for use in Lisp keybindings.
* @param args Lisp arguments (unused)
* @param e Error pointer for Lisp error handling
* @param ctx Lisp context
* @return lisp_null()
* @see editorInsertNewLine()
*/
Lisp l_editorInsertNewLine(Lisp args, LispError *e, LispContext ctx) {
editorInsertNewLine();
return lisp_null();
return lisp_null();
}
/**
* @brief Lisp function to insert a tab (spaces) at cursor
* @details Inserts TAB_LENGTH spaces at the current cursor position.
* @param args Lisp arguments (unused)
* @param e Error pointer for Lisp error handling
* @param ctx Lisp context
* @return lisp_null()
* @note Uses E.constantes.TAB_LENGTH for indentation width
*/
Lisp l_editorInserTab(Lisp args, LispError *e, LispContext ctx) {
for (int i = 0; i<E.constantes.TAB_LENGTH; ++i) {
editorInsertChar(' ');
}
return lisp_null();
}
/**
* @brief Lisp function to move cursor to beginning of line
* @details Moves cursor to column 0 of the current line.
* @param args Lisp arguments (unused)
* @param e Error pointer for Lisp error handling
* @param ctx Lisp context
* @return lisp_null()
* @note Updates global editor state E
*/
Lisp moveCursorBeginLine(Lisp args, LispError *e, LispContext ctx) {
E.cursor_x = 0;
return lisp_null();
}
Lisp moveCursorEndLine(Lisp args, LispError* e, LispContext ctx) {
/**
* @brief Lisp function to move cursor to end of line
* @details Moves cursor to the end of the current line content.
* @param args Lisp arguments (unused)
* @param e Error pointer for Lisp error handling
* @param ctx Lisp context
* @return lisp_null()
* @note Updates global editor state E
*/
Lisp moveCursorEndLine(Lisp args, LispError *e, LispContext ctx) {
if (E.cursor_y < E.numrows) {
E.cursor_x = E.row[E.cursor_y].size;
}
return lisp_null();
}
Lisp deletePreviousChar(Lisp args, LispError* e, LispContext ctx) {
/**
* @brief Lisp function to delete character before cursor
* @details Wrapper around editorDelChar() for use in Lisp keybindings.
* @param args Lisp arguments (unused)
* @param e Error pointer for Lisp error handling
* @param ctx Lisp context
* @return lisp_null()
* @see editorDelChar()
*/
Lisp deletePreviousChar(Lisp args, LispError *e, LispContext ctx) {
editorDelChar();
return lisp_null();
}
Lisp editorMoveCursorPageUp(Lisp args, LispError* e, LispContext ctx) {
/**
* @brief Lisp function to move cursor up by one screen
* @details Scrolls up one full screen height, moving cursor to top of visible area.
* @param args Lisp arguments (unused)
* @param e Error pointer for Lisp error handling
* @param ctx Lisp context
* @return lisp_null()
* @note Updates global editor state E
* @see editorMoveCursor()
*/
Lisp editorMoveCursorPageUp(Lisp args, LispError *e, LispContext ctx) {
E.cursor_y = E.row_offset;
int times = E.screenrows;
while (--times) {
@@ -111,7 +275,17 @@ Lisp editorMoveCursorPageUp(Lisp args, LispError* e, LispContext ctx) {
return lisp_null();
}
Lisp editorMoveCursorPageDown(Lisp args, LispError* e, LispContext ctx) {
/**
* @brief Lisp function to move cursor down by one screen
* @details Scrolls down one full screen height, moving cursor to bottom of visible area.
* @param args Lisp arguments (unused)
* @param e Error pointer for Lisp error handling
* @param ctx Lisp context
* @return lisp_null()
* @note Updates global editor state E
* @see editorMoveCursor()
*/
Lisp editorMoveCursorPageDown(Lisp args, LispError *e, LispContext ctx) {
E.cursor_y = E.row_offset + E.screenrows - 1;
if (E.cursor_y > E.numrows) {
E.cursor_y = E.numrows;
@@ -124,18 +298,162 @@ Lisp editorMoveCursorPageDown(Lisp args, LispError* e, LispContext ctx) {
return lisp_null();
}
/**
* @brief Lisp function to open a file
* @details Prompts user for filename and opens the file for editing.
* @param args Lisp arguments (unused)
* @param e Error pointer for Lisp error handling
* @param ctx Lisp context
* @return lisp_null()
* @note Updates global editor state E
* @see editorOpen()
* @see editorPrompt()
*/
Lisp editorOpenFile(Lisp args, LispError *e, LispContext ctx) {
char *filename = editorPrompt("Path : %s");
if (filename)
char *filename = editorPrompt("Open : %s", getenv("PWD"), 1);
if (filename){
editorOpen(filename);
}
free(filename);
return lisp_null();
}
/**
* @brief Lisp function to insert a character
* @details Extracts a character from Lisp string argument and inserts it at cursor.
* @param args Lisp list with one string argument
* @param e Error pointer for Lisp error handling
* @param ctx Lisp context
* @return lisp_null()
* @note Uses first character of the string argument
*/
Lisp editorPrintC(Lisp args, LispError *e, LispContext ctx) {
char c = lisp_char(lisp_car(args));
char c = lisp_string(lisp_car(args))[0];
editorInsertChar(c);
return lisp_null();
}
/**
* @brief Lisp function to load and execute a package
* @details Loads a Lisp package from the user's packages directory
* (~/.beluga/packages/<package_name>/init.lisp) and evaluates it.
* @param args Lisp list with one argument: package name (string)
* @param e Error pointer for Lisp error handling
* @param ctx Lisp context
* @return lisp_null()
* @note Package files must be valid Lisp code
* @note Package directory defaults to ~/.beluga/packages/
*/
Lisp addPackage(Lisp args, LispError *e, LispContext ctx) {
const char *package_name = lisp_string(lisp_car(args));
fprintf(stderr, "%s\n", package_name);
char *package_dir = (char *)calloc(256, sizeof(char));
FILE *fd_package = NULL;
strcat(package_dir, getenv("HOME"));
strcat(package_dir, "/.beluga/packages/");
strcat(package_dir, package_name);
strcat(package_dir, "/init.lisp");
fprintf(stderr, "%s\n", package_dir);
fd_package = fopen(package_dir, "r");
lisp_eval(lisp_read_file(fd_package, &E.ctx_error, E.ctx), &E.ctx_error,
E.ctx);
fclose(fd_package);
free(package_dir);
return lisp_null();
}
/**
* @brief Lisp function to delete the current row
* @details Removes the line at the current cursor position.
* @param args Lisp arguments (unused)
* @param e Error pointer for Lisp error handling
* @param ctx Lisp context
* @return lisp_null()
* @note Updates global editor state E
* @see editorDelRow()
*/
Lisp editorDelRow_L(Lisp args, LispError *e, LispContext ctx) {
editorDelRow(E.cursor_y);
return lisp_null();
}
/**
* @brief Lisp function to search for text
* @details Wrapper around editorFind() for use in Lisp keybindings.
* @param args Lisp arguments (unused)
* @param e Error pointer for Lisp error handling
* @param ctx Lisp context
* @return lisp_null()
* @see editorFind()
*/
Lisp editorFind_L(Lisp args, LispError *e, LispContext ctx) {
fprintf(stderr, "LispFind\n");
editorFind();
return lisp_null();
}
/**
* @brief Lisp function to read character at cursor
* @details Returns the character at the current cursor position as a Lisp character.
* Returns 'a' if at end of line.
* @param args Lisp arguments (unused)
* @param e Error pointer for Lisp error handling
* @param ctx Lisp context
* @return Lisp character object representing the character at cursor
*/
Lisp editorReadChar_L(Lisp args, LispError *e, LispContext ctx) {
Lisp returned_char;
if (E.row[E.cursor_y].render[E.cursor_x] == 0) {
returned_char = lisp_make_char('a');
} else {
returned_char = lisp_make_char(E.row[E.cursor_y].render[E.cursor_x]);
}
return returned_char;
}
/**
* @brief Lisp function to set the current prefix mode
* @details Changes the editor's prefix state to a named prefix, affecting which
* keybindings are active. Updates status message to show active prefix.
* @param args Lisp list with one argument: prefix name (string)
* @param e Error pointer for Lisp error handling
* @param ctx Lisp context
* @return lisp_null()
* @note Updates global editor state E (prefix_state)
* @see find_prefix()
*/
Lisp editorSetPrefix(Lisp args, LispError *e, LispContext ctx) {
/*
* Set the prefix state of editor to the prefix in argument
*/
const char *prefix_name = lisp_string(lisp_car(args));
struct prefix_t prefix = find_prefix(prefix_name);
E.prefix_state = prefix.prefix_id;
editorSetStatusMessage("prefix %s", prefix.prefix_name);
fprintf(stderr, "%s set\n", prefix_name);
return lisp_null();
}
/**
* @brief Lisp function to define a new prefix modifier
* @details Registers a named prefix modifier that can be used with keybindings
* to create context-aware command sequences (e.g., Ctrl-X as a prefix).
* @param args Lisp list with one argument: prefix name (string, max 64 chars)
* @param e Error pointer for Lisp error handling
* @param ctx Lisp context
* @return lisp_null()
* @note Updates global editor state E (prefix array)
*/
Lisp editorPrefix(Lisp args, LispError *e, LispContext ctx) {
E.prefix = (struct prefix_t *)realloc(E.prefix, (++(E.number_of_prefix) + 1) *
sizeof(struct prefix_t));
E.prefix[E.number_of_prefix].prefix_id = E.number_of_prefix;
strncpy(E.prefix[E.number_of_prefix].prefix_name, lisp_string(lisp_car(args)),
64);
return lisp_null();
}
+5 -1
View File
@@ -1,6 +1,5 @@
#include "../include/editor_op.h"
#include "../include/row_op.h"
#include "data.h"
extern struct editorConfig E;
@@ -14,6 +13,10 @@ void editorInsertChar(int c) {
}
void editorInsertNewLine() {
/*
* Add new line and place the cursor at the beginning of it
*/
fprintf(stderr, "Inserting new line\n");
erow *row;
if (!E.cursor_x) {
editorInsertRow(E.cursor_y, "", 0);
@@ -28,6 +31,7 @@ void editorInsertNewLine() {
}
++E.cursor_y;
E.cursor_x = 0;
fprintf(stderr, "Insert new line done\n");
}
void editorDelChar() {
+81 -3
View File
@@ -1,7 +1,14 @@
/**
* @file file_io.c
* @brief File I/O operations module for the Beluga text editor
* @details Handles file loading, saving, searching, and buffer management.
* Provides functionality for opening/closing files, persisting changes to disk,
* and searching for text patterns within the document.
*/
#include "../include/file_io.h"
#include "../include/input.h"
#include "../include/output.h"
#include "data.h"
#include <fcntl.h>
#include <stdio.h>
#include <stdlib.h>
@@ -15,6 +22,15 @@ extern ssize_t getline(char **restrict lineptr, size_t *restrict n,
extern int ftruncate(int fd, off_t length);
extern struct editorConfig E;
/**
* @brief Converts all editor rows to a single string buffer
* @details Concatenates all row content into a single allocated buffer with
* newlines between rows. Useful for file saving and buffer operations.
* @param buffer_len Pointer to integer where total buffer length will be stored
* @return Pointer to dynamically allocated buffer containing all row data.
* Rows are separated by newline characters.
* @note Caller is responsible for freeing the returned buffer
*/
char *editorRowsToString(int *buffer_len) {
int tot_len = 0;
int j;
@@ -37,20 +53,43 @@ char *editorRowsToString(int *buffer_len) {
return buf;
}
/**
* @brief Closes the current file and resets editor state
* @details Clears all rows, resets cursor position, scroll offsets, and file metadata.
* Does not prompt to save unsaved changes.
* @note Updates global editor state E
*/
void editorCloseFile(void) {
E.cursor_x = 0;
E.cursor_y = 0;
E.rx = 0;
E.row_offset = 0;
E.col_offset = 0;
for (int i = 0; i < E.numrows; ++i) {
free(E.row[i].chars);
free(E.row[i].render);
}
E.numrows = 0;
free(E.row);
E.row = NULL;
E.dirty = 0;
free(E.filename);
E.filename = NULL;
E.status_msg[0] = '\0';
E.status_msg_time = 0;
}
/**
* @brief Opens a file for editing
* @details Loads file content into editor rows, one line per row. If another file
* is already open, it is closed first (without saving). File is opened in a+
* (read/append) mode to allow both reading and modification.
* @param filename Path to the file to open (relative or absolute)
* @note Updates global editor state E
* @note Calls die() on file open failure
* @note Newline characters are stripped from loaded lines
* @see editorInsertRow()
*/
void editorOpen(char *filename) {
FILE *fp;
@@ -60,7 +99,6 @@ void editorOpen(char *filename) {
E.state = READ_AND_WRITE;
}
free(E.filename);
E.filename = strdup(filename);
fp = fopen(filename, "a+");
@@ -77,18 +115,30 @@ void editorOpen(char *filename) {
--line_len;
}
editorInsertRow(E.numrows, line, line_len);
free(line);
line = NULL;
}
free(line);
fclose(fp);
E.dirty = 0;
}
/**
* @brief Saves the current file to disk
* @details Prompts for filename if not set, converts all rows to a buffer,
* writes to disk using open/ftruncate/write, and updates dirty flag.
* Displays status messages on success or failure.
* @note Updates global editor state E (dirty flag)
* @note If no filename is set, prompts user via editorPrompt()
* @note Uses O_RDWR | O_CREAT with mode 0644
* @see editorRowsToString()
*/
void editorSave() {
int len;
char *buf;
int fd;
if (E.filename == NULL) {
E.filename = editorPrompt("Save as: %s (ESC to cancel)");
E.filename = editorPrompt("Save as: %s (ESC to cancel)", "", 1);
if (E.filename == NULL) {
editorSetStatusMessage("Save aborted");
return;
@@ -111,3 +161,31 @@ void editorSave() {
free(buf);
editorSetStatusMessage("Can't save! I/O error: %s", strerror(errno));
}
/**
* @brief Searches for a string in the document
* @details Prompts user for a search query, then searches forward from current
* cursor position. Updates cursor position to the first match found.
* @note Updates global editor state E (cursor position, row_offset)
* @note Search is case-sensitive and operates on rendered line content
* @note Searches begin from the line after current cursor position
* @see editorPrompt()
* @see editorRowRxToCx()
*/
void editorFind() {
fprintf(stderr, "searching\n");
char *query = editorPrompt("Search: %s (ESC to cancel)", "", 0);
if (query == NULL) return;
int i;
for (i = E.cursor_y + 1; i < E.numrows; i++) {
erow *row = &E.row[i];
char *match = strstr(row->render, query);
if (match) {
E.cursor_y = i;
E.cursor_x = editorRowRxToCx(row, match - row->render);
E.row_offset = E.numrows;
break;
}
}
free(query);
}
+37 -21
View File
@@ -1,39 +1,46 @@
#include "../include/init.h"
#include "../include/builtins.h"
#include "../include/data.h"
#include "../include/terminal.h"
#include "../include/builtins.h"
#include <stdio.h>
#include <stdlib.h>
#define LISP_IMPLEMENTATION
#include "../lisp-interpreter/dist/lisp.h"
#include "../lisp-interpreter/dist/lisp_lib.h"
extern struct editorConfig;
#include "../include/lisp.h"
#include "../include/lisp_lib.h"
struct editorConfig;
void registerBuiltin(char *key_sequence, LispCFunc f) {
lisp_env_define(E.ctx.p->env, lisp_make_symbol(key_sequence, E.ctx),
lisp_make_func(f), E.ctx);
}
void initBuiltins() {
// move cursor
registerBuiltin("MOVE-CURSOR", moveCursor);
registerBuiltin("MAP-KEY", mapKey);
registerBuiltin("EDITOR-QUIT", editorQuit);
registerBuiltin("EDITOR-SAVE", l_editorSave);
registerBuiltin("EDITOR-INSERT-NEW-LINE", l_editorInsertNewLine);
registerBuiltin("MOVE-CURSOR-BEG-LINE", moveCursorBeginLine);
registerBuiltin("MOVE-CURSOR-END-LINE", moveCursorEndLine);
registerBuiltin("EDITOR-DELETE-PREVIOUS-CHAR", deletePreviousChar);
registerBuiltin("MOVE-CURSOR-PAGE-UP", editorMoveCursorPageUp);
registerBuiltin("MOVE-CURSOR-PAGE-DOWN", editorMoveCursorPageDown);
registerBuiltin("EDITOR-OPEN-FILE", editorOpenFile);
registerBuiltin("EDITOR-INSERT-CHAR", editorPrintC);
registerBuiltin("move-cursor", moveCursor);
registerBuiltin("map-key", mapKey);
registerBuiltin("editor-quit", editorQuit);
registerBuiltin("editor-save", l_editorSave);
registerBuiltin("editor-insert-new-line", l_editorInsertNewLine);
registerBuiltin("move-cursor-beg-line", moveCursorBeginLine);
registerBuiltin("move-cursor-end-line", moveCursorEndLine);
registerBuiltin("editor-delete-previous-char", deletePreviousChar);
registerBuiltin("move-cursor-page-up", editorMoveCursorPageUp);
registerBuiltin("move-cursor-page-down", editorMoveCursorPageDown);
registerBuiltin("editor-open-file", editorOpenFile);
registerBuiltin("editor-insert-char", editorPrintC);
registerBuiltin("add-package", addPackage);
registerBuiltin("editor-del-row", editorDelRow_L);
registerBuiltin("editor-find", editorFind_L);
registerBuiltin("editor-read-char", editorReadChar_L);
registerBuiltin("add-prefix", editorPrefix);
registerBuiltin("editor-set-prefix", editorSetPrefix);
registerBuiltin("editor-insert-tab", l_editorInserTab);
}
void initEditor() {
E.init_file_path = (char *)calloc(256, sizeof(char));
E.cursor_x = 0;
E.cursor_y = 0;
E.rx = 0;
@@ -52,9 +59,18 @@ void initEditor() {
E.screenrows -= 2;
E.number_of_keybinds = 0;
E.number_of_prefix = 0;
// General prefix is 0 (no prefix)
E.prefix = (struct prefix_t *)malloc(sizeof(struct prefix_t));
E.prefix[0].prefix_id = 0;
strncpy(E.prefix[0].prefix_name, "no-prefix", 64);
E.fd_init_file = fopen("config/init.lisp", "r");
E.prefix_state = 0;
strcat(E.init_file_path, getenv("HOME"));
strcat(E.init_file_path, "/.beluga/config/init.lisp");
// printf("%s\n", init_file_path);
E.fd_init_file = fopen(E.init_file_path, "r");
E.ctx = lisp_init();
E.env = lisp_env(E.ctx);
lisp_lib_load(E.ctx);
@@ -67,7 +83,7 @@ void initEditor() {
die("init failed");
}
lisp_eval(E.ctx_data, &E.ctx_error, E.ctx);
// To modify
E.constantes.TAB_LENGTH =
+166 -17
View File
@@ -1,26 +1,112 @@
#include "../include/input.h"
#include "../include/define.h"
#include "../include/editor_op.h"
#include "../include/output.h"
#include "../include/define.h"
#include <ctype.h>
#include <dirent.h>
#include <stdint.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <unistd.h>
#include <sys/stat.h>
extern struct editorConfig E;
/**
* \fn char * editorPrompt(struct editorConfig *E, char *prompt)
* \brief Return user input in a prompt when enter is hit. */
* @file input.c
* @brief Input handling module for the Beluga text editor
* @details Manages user input processing, key bindings, cursor movement, and file path completion
*/
char *editorPrompt(char *prompt) {
/**
* @brief Returns the first file completion match for the given path
* @details Searches the directory containing the given path prefix and returns
* the first file or directory entry that matches the filename prefix.
* Appends a trailing slash for directory entries.
* @param path The file path to complete (can be relative or absolute)
* @return Pointer to the completed file path (dynamically allocated), or NULL if:
* - path ends with '/' (already a directory)
* - no matching entries found
* - directory cannot be opened
* @note Caller is responsible for freeing the returned string
* @note Uses static buffer internally; may return stale pointers across calls
*/
const char *file_completion(const char *path) {
DIR *dir;
struct dirent *entry;
char directory[128];
char predict[128];
const char *last_slash;
int predict_len = 0;
size_t dir_len;
// path is a directory
if (path[strlen(path) - 1] == '/') {
return path;
}
// Find dir name
last_slash = strrchr(path, '/');
if (last_slash) {
dir_len = last_slash - path + 1; // length of dir_path
strncpy(directory, path, dir_len);
predict_len = strlen(path) - dir_len;
strncpy(predict, last_slash + 1, predict_len);
directory[dir_len] = '\0';
predict[predict_len] = '\0';
fprintf(stderr, "%s %s\n", directory, predict);
} else {
return NULL;
}
dir = opendir(directory);
if (!dir)
return NULL;
while ((entry = readdir(dir)) != NULL) {
if (strncmp(entry->d_name, predict, predict_len) == 0) {
static char full_path[512];
snprintf(full_path, sizeof(full_path), "%s%s", directory, entry->d_name);
struct stat st;
if (stat(full_path, &st) == 0 && S_ISDIR(st.st_mode)) {
strcat(full_path, "/"); // add slash for directories
}
closedir(dir);
return strdup(full_path);
}
}
// Cleanup when no more entries
closedir(dir);
dir = NULL;
free(entry);
return NULL;
}
/**
* @brief Displays an interactive prompt and returns user input
* @details Allows the user to enter text in a prompt with optional path completion
* via Tab key. Supports backspace, delete, and escape key handling. Dynamically
* allocates memory for the input buffer.
* @param prompt The prompt message format string (printf-style)
* @param placeHolder Initial text to display in the input buffer
* @param bPathMode If non-zero, enables Tab key file path completion
* @return Pointer to the user-entered text (dynamically allocated), or NULL if:
* - User pressed ESC to cancel
* - Input buffer is empty when Enter is pressed
* @note Caller is responsible for freeing the returned string
* @note Uses editorReadKey() for input and editorRefreshScreen() for display
*/
char *editorPrompt(char *prompt, char *placeHolder, char bPathMode) {
size_t buf_size = 128;
char *buf = malloc(buf_size);
size_t buf_len = 0;
int c = 0;
buf[0] = '\0';
strcpy(buf, placeHolder);
buf_len = strlen(placeHolder);
while (1) {
editorSetStatusMessage(prompt, buf);
@@ -39,6 +125,26 @@ char *editorPrompt(char *prompt) {
editorSetStatusMessage("");
return buf;
}
} else if (bPathMode && c == '\t') {
char path[128];
char *pwd;
if (buf[0] != '/') {
pwd = getenv("PWD");
fprintf(stderr, "%s\n", pwd);
memcpy(path, pwd, strlen(pwd));
path[strlen(pwd)] = '/';
strncat(path, buf, buf_len);
} else {
strcpy(path, buf);
}
memset(buf, 0, 128);
buf_len = 0;
char * buf_complete = (char *) file_completion(path);
strcpy(buf, buf_complete);
free(buf_complete);
buf_len = strlen(buf);
buf[buf_len] = '\0';
} else if (!iscntrl(c) && c < 128) {
if (buf_len == buf_size - 1) {
buf_size *= 2;
@@ -50,17 +156,29 @@ char *editorPrompt(char *prompt) {
}
}
/**
* @brief Converts a key code to its string representation
* @details Translates raw key codes (including special keys, control keys,
* and regular characters) into human-readable string formats suitable for
* display and keybinding configuration.
* @param key The key code to convert
* @return Pointer to static buffer containing the string representation.
* Examples: "ENTER", "ARROW-UP", "CTRL-a", "TAB", "DELETE", etc.
* @note Returns pointer to static buffer; string is overwritten on next call
* @note Non-printable characters are formatted as "KEY-<number>"
*/
char *key_to_string(int key) {
static char key_str[32];
char tmp[10];
sprintf(tmp, "%d", key);
// First test enter key
if (key == '\r') {
strcpy(key_str, "ENTER");
} else if (key == '\t') {
strcpy(key_str, "TAB");
} else if (key >= 1 && key <= 26) { // CTRL keys
snprintf(key_str, sizeof(key_str), "CTRL-%c", 'a' + key - 1);
} else {
@@ -85,9 +203,8 @@ char *key_to_string(int key) {
strcpy(key_str, "PAGE-DOWN");
break;
case DEL_KEY:
fprintf(stderr, "delete key\n");
strcpy(key_str, "DEL");
break;
case BACKSPACE:
strcpy(key_str, "BACKSPACE");
@@ -116,8 +233,16 @@ char *key_to_string(int key) {
return key_str;
}
void editorMoveCursor(int key) {
/**
* @brief Moves the cursor based on arrow key input
* @details Updates cursor position (E.cursor_x, E.cursor_y) based on the given
* key direction. Handles line wrapping and boundary conditions. Prevents cursor
* from exceeding line lengths.
* @param key The arrow key code (ARROW_UP, ARROW_DOWN, ARROW_LEFT, ARROW_RIGHT)
* @return 1 if cursor movement was valid, 0 if cursor was constrained to line boundary
* @note Updates global editor state E
*/
int editorMoveCursor(int key) {
erow *row = (E.cursor_y >= E.numrows) ? NULL : &E.row[E.cursor_y];
int row_len;
switch (key) {
@@ -153,24 +278,49 @@ void editorMoveCursor(int key) {
row_len = row ? row->size : 0;
if (E.cursor_x > row_len) {
E.cursor_x = row_len;
return 0;
}
return 1;
}
/**
* @brief Executes the command bound to a key sequence
* @details Searches the keybinding table for a matching key sequence and
* prefix state, then evaluates the associated Lisp command.
* @param key_sequence The string representation of the key sequence
* @return 1 if a matching keybinding was found and executed, 0 otherwise
* @note Updates global editor state E (prefix_state)
* @note Uses Lisp interpreter to evaluate bound commands
*/
int executeKeyBind(char *key_sequence) {
int i;
int previous_state = 0;
fprintf(stderr, "pressed %s\n", key_sequence);
for (i = 0; i < E.number_of_keybinds; ++i) {
if (!strcmp(key_sequence, E.key_binds[i].key_sequence)) {
fprintf(stderr, "lisp function %s\n", key_sequence);
// It's a symbol, create a function call
lisp_eval(lisp_cons(E.key_binds[i].command, lisp_null(), E.ctx),
&E.ctx_error, E.ctx);
return 1;
if (E.prefix_state != E.key_binds[i].prefix_id) {
continue;
}
previous_state = E.prefix_state;
// It's a symbol, create a function call
lisp_eval(lisp_cons(E.key_binds[i].command, lisp_null(), E.ctx),
&E.ctx_error, E.ctx);
if (E.prefix_state == previous_state)
E.prefix_state = 0;
return 1;
}
}
return 0;
}
/**
* @brief Processes a single keypress from the user
* @details Reads a key, checks if it matches any registered keybinding,
* and either executes the bound command or inserts the character. Resets
* the quit buffer counter on successful key processing.
* @note Updates global editor state E
* @note Calls editorReadKey() to get input and editorInsertChar() for unbound keys
*/
void editorProcessKeypress() {
int c = editorReadKey();
@@ -179,5 +329,4 @@ void editorProcessKeypress() {
}
editorInsertChar(c);
E.quit_times_buffer = E.constantes.QUIT_TIMES;
}
+63 -2
View File
@@ -1,11 +1,30 @@
/**
* @file output.c
* @brief Screen rendering and output module for the Beluga text editor
* @details Handles all screen updates, cursor positioning, status bar rendering,
* and display synchronization using ANSI escape sequences
*/
#include "../include/output.h"
#include "../include/syntax_highlighter.h"
#include <stdarg.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <time.h>
extern struct editorConfig E;
/**
* @brief Renders all visible rows to the screen buffer
* @details Draws file content with syntax highlighting, handles line wrapping,
* and displays tilde characters (~) for empty lines. Shows welcome message
* when no file is open.
* @param ab Pointer to append buffer structure for accumulating output
* @note Respects E.row_offset and E.col_offset for scrolling
* @note Clears to end of each line after content
* @see editorRefreshScreen()
*/
void editorDrawRows(struct abuf *ab) {
int y;
char welcome[80];
@@ -41,13 +60,22 @@ void editorDrawRows(struct abuf *ab) {
len = 0;
if (len > E.screencols)
len = E.screencols;
abAppend(ab, &E.row[file_row].render[E.col_offset], len);
char * highlighted = highlight_line(&E.row[file_row].render[E.col_offset], &E.row[file_row].rsize);
abAppend(ab, highlighted, E.row[file_row].rsize);
free(highlighted);
}
abAppend(ab, ERASE_END_LINE, 3);
abAppend(ab, "\r\n", 2);
}
}
/**
* @brief Updates scroll offsets to keep cursor visible on screen
* @details Adjusts E.row_offset and E.col_offset to ensure the cursor remains
* within the visible viewport. Also updates E.rx (rendered x-coordinate).
* @note Updates global editor state E
* @see editorRowCxToRx()
*/
void editorScroll() {
E.rx = E.cursor_x;
if (E.cursor_y < E.numrows) {
@@ -68,6 +96,13 @@ void editorScroll() {
}
}
/**
* @brief Renders the status bar at the bottom of the screen
* @details Displays filename, line count, dirty flag, and current cursor position
* in an inverted color bar. Right-aligns the cursor position indicator.
* @param ab Pointer to append buffer structure for accumulating output
* @note Uses ANSI escape codes for color inversion
*/
void editorDrawStatusBar(struct abuf *ab) {
int len, render_len;
char status[80], render_status[80];
@@ -95,6 +130,13 @@ void editorDrawStatusBar(struct abuf *ab) {
abAppend(ab, "\r\n", 2);
}
/**
* @brief Renders the message bar below the status bar
* @details Displays temporary status messages for a limited time (5 seconds).
* Only displays message if within time window and within screen width.
* @param ab Pointer to append buffer structure for accumulating output
* @note Messages are set by editorSetStatusMessage()
*/
void editorDrawMessageBar(struct abuf *ab) {
int msg_len = strlen(E.status_msg);
abAppend(ab, ERASE_END_LINE, 3);
@@ -106,6 +148,16 @@ void editorDrawMessageBar(struct abuf *ab) {
}
}
/**
* @brief Performs complete screen refresh and buffer synchronization
* @details Clears screen, redraws all visible content (rows, status bar, message bar),
* positions cursor, and writes accumulated buffer to stdout. This is the main
* rendering function called each frame.
* @note Updates global editor state E (via editorScroll())
* @see editorDrawRows()
* @see editorDrawStatusBar()
* @see editorDrawMessageBar()
*/
void editorRefreshScreen() {
editorScroll();
struct abuf ab = ABUF_INIT;
@@ -123,11 +175,20 @@ void editorRefreshScreen() {
abAppend(&ab, buf, strlen(buf));
abAppend(&ab, SHOW_CURSOR, 6);
write(STDOUT_FILENO, ab.b, ab.len);
abFree(&ab);
}
/**
* @brief Sets a temporary status message for display
* @details Formats and stores a message that will be displayed in the message bar
* for 5 seconds. Uses printf-style variable argument formatting.
* @param fmt Printf-style format string
* @param ... Variable arguments for format string
* @note Updates global editor state E (status_msg, status_msg_time)
* @see editorDrawMessageBar()
*/
void editorSetStatusMessage(const char *fmt, ...) {
va_list ap;
va_start(ap, fmt);
+12 -1
View File
@@ -1,5 +1,4 @@
#include "../include/row_op.h"
#include "data.h"
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
@@ -19,6 +18,18 @@ int editorRowCxToRx(erow *row, int cursor_x) {
return render_x;
}
int editorRowRxToCx(erow *row, int rx) {
int cur_rx = 0;
int cx;
for (cx = 0; cx < row->size; cx++) {
if (row->chars[cx] == '\t')
cur_rx += (E.constantes.TAB_LENGTH - 1) - (cur_rx % E.constantes.TAB_LENGTH);
cur_rx++;
if (cur_rx > rx) return cx;
}
return cx;
}
/**
* \fn editorUpdateRow(erow *row)
* \brief Copy content of \p row in \p row->render.
+163
View File
@@ -0,0 +1,163 @@
#include "../include/syntax_highlighter.h"
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
const char *c_keywords[] = {
"if", "else", "while", "for", "do", "switch", "case", "break",
"continue", "return", "goto", "struct", "union", "enum",
"typedef", "static", "extern", "const", "volatile", "sizeof",
"auto", "register", "inline", "restrict", NULL
};
// C types
const char *c_types[] = {
"int", "char", "float", "double", "void", "long", "short",
"unsigned", "signed", "bool", NULL
};
// Check if character is alphanumeric or underscore
int is_word_char(char c) {
return (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') ||
(c >= '0' && c <= '9') || c == '_';
}
// Check if string is a keyword
int is_keyword(const char *word) {
for (int i = 0; c_keywords[i] != NULL; i++) {
if (strcmp(word, c_keywords[i]) == 0) return 1;
}
return 0;
}
// Check if string is a type
int is_type(const char *word) {
for (int i = 0; c_types[i] != NULL; i++) {
if (strcmp(word, c_types[i]) == 0) return 1;
}
return 0;
}
// Get color code for token type
const char *get_color(TokenType type) {
switch (type) {
case TOKEN_KEYWORD: return COLOR_KEYWORD;
case TOKEN_TYPE: return COLOR_TYPE;
case TOKEN_STRING: return COLOR_STRING;
case TOKEN_COMMENT: return COLOR_COMMENT;
case TOKEN_NUMBER: return COLOR_NUMBER;
default: return COLOR_DEFAULT;
}
}
// Highlight a line of C code and return the highlighted string
// Returns a newly allocated string that must be freed by the caller
char *highlight_line(const char *line, int *length) {
char *result = malloc(1024); // Allocate space for result
int result_pos = 0;
int i = 0;
while (line[i] != '\0' && line[i] != '\n') {
// Skip whitespace
if (line[i] == ' ' || line[i] == '\t') {
result[result_pos++] = line[i++];
continue;
}
// Handle line comments
if (line[i] == '/' && line[i + 1] == '/') {
result_pos += sprintf(&result[result_pos], "%s", COLOR_COMMENT);
while (line[i] != '\0' && line[i] != '\n') {
result[result_pos++] = line[i++];
}
result_pos += sprintf(&result[result_pos], "%s", COLOR_RESET);
continue;
}
// Handle block comments
if (line[i] == '/' && line[i + 1] == '*') {
result_pos += sprintf(&result[result_pos], "%s", COLOR_COMMENT);
result[result_pos++] = line[i++];
result[result_pos++] = line[i++];
while (line[i] != '\0') {
if (line[i] == '*' && line[i + 1] == '/') {
result[result_pos++] = line[i++];
result[result_pos++] = line[i++];
break;
}
result[result_pos++] = line[i++];
}
result_pos += sprintf(&result[result_pos], "%s", COLOR_RESET);
continue;
}
// Handle strings
if (line[i] == '"') {
result_pos += sprintf(&result[result_pos], "%s\"", COLOR_STRING);
i++;
while (line[i] != '\0' && line[i] != '"') {
if (line[i] == '\\') {
result[result_pos++] = line[i++];
result[result_pos++] = line[i++];
} else {
result[result_pos++] = line[i++];
}
}
if (line[i] == '"') result[result_pos++] = line[i++];
result_pos += sprintf(&result[result_pos], "%s", COLOR_RESET);
continue;
}
// Handle character literals
if (line[i] == '\'') {
result_pos += sprintf(&result[result_pos], "%s'", COLOR_STRING);
i++;
while (line[i] != '\0' && line[i] != '\'') {
if (line[i] == '\\') {
result[result_pos++] = line[i++];
result[result_pos++] = line[i++];
} else {
result[result_pos++] = line[i++];
}
}
if (line[i] == '\'') result[result_pos++] = line[i++];
result_pos += sprintf(&result[result_pos], "%s", COLOR_RESET);
continue;
}
// Handle numbers
if (line[i] >= '0' && line[i] <= '9') {
result_pos += sprintf(&result[result_pos], "%s", COLOR_NUMBER);
while (is_word_char(line[i]) || line[i] == '.') {
result[result_pos++] = line[i++];
}
result_pos += sprintf(&result[result_pos], "%s", COLOR_RESET);
continue;
}
// Handle identifiers and keywords
if (is_word_char(line[i])) {
int start = i;
while (is_word_char(line[i])) i++;
char word[256];
strncpy(word, &line[start], i - start);
word[i - start] = '\0';
TokenType type = TOKEN_DEFAULT;
if (is_keyword(word)) type = TOKEN_KEYWORD;
else if (is_type(word)) type = TOKEN_TYPE;
result_pos += sprintf(&result[result_pos], "%s%s%s",
get_color(type), word, COLOR_RESET);
continue;
}
// Handle operators and other characters
result[result_pos++] = line[i++];
}
result[result_pos] = '\0';
*length = result_pos + 1;
return result;
}