Forgot to tell GC that ports are now pair-like.
[scheme.forth.jl.git] / src / scheme.4th
1 vocabulary scheme
2 scheme definitions
3
4 include term-colours.4th
5 include defer-is.4th
6 include catch-throw.4th
7 include integer.4th
8 include float.4th
9
10 include debugging.4th
11
12 defer read
13 defer eval
14 defer print
15
16 defer collect-garbage
17
18 \ ---- Types ---- {{{
19
20 variable nexttype
21 0 nexttype !
22 : make-type
23     create nexttype @ ,
24     1 nexttype +!
25     does> @ ;
26
27 make-type fixnum-type
28 make-type flonum-type
29 make-type ratnum-type
30 make-type boolean-type
31 make-type character-type
32 make-type string-type
33 make-type nil-type
34 make-type none-type
35 make-type pair-type
36 make-type symbol-type
37 make-type primitive-proc-type
38 make-type compound-proc-type
39 make-type port-type
40 : istype? ( obj type -- obj bool )
41     over = ;
42
43 \ }}}
44
45 \ ---- Exceptions ---- {{{
46
47 variable nextexception
48 1 nextexception !
49 : make-exception 
50     create nextexception @ ,
51     1 nextexception +!
52     does> @ ;
53
54 make-exception recoverable-exception
55 make-exception unrecoverable-exception
56
57 : display-exception-msg ( addr count -- )
58     bold fg red
59     ." Exception: "
60     type
61     reset-term ;
62
63 : throw" immediate 
64     [compile] s"
65
66     ['] rot , ['] dup ,
67
68     [compile] if
69         ['] -rot ,
70         ['] display-exception-msg ,
71     [compile] then
72
73     ['] throw ,
74 ;
75
76 \ }}}
77
78 \ ---- List-structured memory ---- {{{
79
80 10000 constant scheme-memsize
81
82 create car-cells scheme-memsize allot
83 create car-type-cells scheme-memsize allot
84 create cdr-cells scheme-memsize allot
85 create cdr-type-cells scheme-memsize allot
86
87 create nextfrees scheme-memsize allot
88 :noname
89     scheme-memsize 0 do
90         i 1+ nextfrees i + !
91     loop
92 ; execute
93         
94 variable nextfree
95 0 nextfree !
96
97 : inc-nextfree
98     nextfrees nextfree @ + @
99     nextfree !
100
101     nextfree @ scheme-memsize >= if
102         collect-garbage
103     then
104
105     nextfree @ scheme-memsize >= if
106         unrecoverable-exception throw s" Out of memory!"
107     then
108 ;
109
110 : cons ( car-obj cdr-obj -- pair-obj )
111     cdr-type-cells nextfree @ + !
112     cdr-cells nextfree @ + !
113     car-type-cells nextfree @ + !
114     car-cells nextfree @ + !
115
116     nextfree @ pair-type
117     inc-nextfree
118 ;
119
120 : car ( pair-obj -- car-obj )
121     drop
122     dup car-cells + @ swap
123     car-type-cells + @
124 ;
125
126 : cdr ( pair-obj -- car-obj )
127     drop
128     dup cdr-cells + @ swap
129     cdr-type-cells + @
130 ;
131
132 : set-car! ( obj pair-obj -- )
133     drop dup
134     rot swap  car-type-cells + !
135     car-cells + !
136 ;
137
138 : set-cdr! ( obj pair-obj -- )
139     drop dup
140     rot swap  cdr-type-cells + !
141     cdr-cells + !
142 ;
143
144 : nil 0 nil-type ;
145 : nil? nil-type istype? ;
146
147 : none 0 none-type ;
148 : none? none-type istype? ;
149
150 : objvar create nil swap , , ;
151
152 : value@ ( objvar -- val ) @ ;
153 : type@ ( objvar -- type ) 1+ @ ;
154 : value! ( newval objvar -- ) ! ;
155 : type! ( newtype objvar -- ) 1+ ! ;
156 : obj! ( newobj objvar -- ) dup rot swap 1+ ! ! ; 
157 : obj@ ( objvar -- obj ) dup @ swap 1+ @ ; 
158
159 : objeq? ( obj obj -- bool )
160     rot = -rot = and ;
161
162 : 2rot ( a1 a2 b1 b2 c1 c2 -- b1 b2 c1 c2 a1 a2 )
163     >R >R ( a1 a2 b1 b2 )
164     2swap ( b1 b2 a1 a2 )
165     R> R> ( b1 b2 a1 a2 c1 c2 )
166     2swap
167 ;
168
169 : -2rot ( a1 a2 b1 b2 c1 c2 -- c1 c2 a1 a2 b1 b2 )
170     2swap ( a1 a2 c1 c2 b1 b2 )
171     >R >R ( a1 a2 c1 c2 )
172     2swap ( c1 c2 a1 a2 )
173     R> R>
174 ;
175
176 \ }}}
177
178 \ ---- Pre-defined symbols ---- {{{
179
180 objvar symbol-table
181
182 : duplicate-charlist ( charlist -- copy )
183     nil? false = if
184         2dup car 2swap cdr recurse cons
185     then ;
186
187 : charlist-equiv ( charlist charlist -- bool )
188
189     2over 2over
190
191     \ One or both nil
192     nil? -rot 2drop
193     if
194         nil? -rot 2drop
195         if
196             2drop 2drop true exit
197         else
198             2drop 2drop false exit
199         then
200     else
201         nil? -rot 2drop
202         if
203             2drop 2drop false exit
204         then
205     then
206
207     2over 2over
208
209     \ Neither nil
210     car drop -rot car drop = if
211             cdr 2swap cdr recurse
212         else
213             2drop 2drop false
214     then
215 ;
216
217 : charlist>symbol ( charlist -- symbol-obj )
218
219     symbol-table obj@
220
221     begin
222         nil? false =
223     while
224         2over 2over
225         car drop pair-type
226         charlist-equiv if
227             2swap 2drop
228             car
229             exit
230         else
231             cdr
232         then
233     repeat
234
235     2drop
236     drop symbol-type 2dup
237     symbol-table obj@ cons
238     symbol-table obj!
239 ;
240
241
242 : cstr>charlist ( addr n -- charlist )
243     dup 0= if
244         2drop nil
245     else
246         2dup drop @ character-type 2swap
247         swap 1+ swap 1-
248         recurse
249
250         cons
251     then
252 ;
253
254 : create-symbol ( -- )
255     bl word
256     count
257
258     cstr>charlist
259     charlist>symbol
260
261     create swap , ,
262     does> dup @ swap 1+ @
263 ;
264
265 create-symbol quote             quote-symbol
266 create-symbol quasiquote        quasiquote-symbol
267 create-symbol unquote           unquote-symbol
268 create-symbol unquote-splicing  unquote-splicing-symbol
269 create-symbol define            define-symbol
270 create-symbol define-macro      define-macro-symbol
271 create-symbol set!              set!-symbol
272 create-symbol ok                ok-symbol
273 create-symbol if                if-symbol
274 create-symbol lambda            lambda-symbol
275 create-symbol Î»                 Î»-symbol
276 create-symbol begin             begin-symbol
277 create-symbol eof               eof-symbol
278
279 \ Symbol to be bound to welcome message procedure by library
280 create-symbol welcome           welcome-symbol
281
282 \ }}}
283
284 \ ---- Port I/O ----  {{{
285
286 ( Ports are pairs with the fid in the car and the peek buffer in the cdr. )
287
288 : fileport>fid ( fileport -- fid )
289     drop pair-type car drop ;
290
291 : get-last-peek ( fileport -- char/nil )
292     drop pair-type cdr ;
293
294 : set-last-peek ( char/nil fileport -- )
295     drop pair-type set-cdr!
296 ;
297
298 : fid>fileport ( fid -- fileport )
299     fixnum-type nil cons drop port-type ;
300
301 : open-input-file ( addr n -- fileport )
302     r/o open-file drop fid>fileport
303 ;
304
305 : close-port ( fileport -- )
306     fileport>fid close-file drop
307 ;
308
309 objvar console-i/o-port
310 0 fixnum-type nil cons drop port-type console-i/o-port obj!
311
312 objvar current-input-port
313 console-i/o-port obj@ current-input-port obj!
314
315 : read-char ( port -- char ) 
316     2dup get-last-peek nil? if
317         2drop
318         2dup console-i/o-port obj@ objeq? if
319             2drop
320             key character-type
321         else
322             fileport>fid pad 1 rot read-file 0= if
323                 eof-symbol
324             else
325                 pad @ character-type
326             then
327         then
328     else
329         nil 2rot set-cdr!
330     then
331 ;
332
333 : peek-char ( port -- char )
334     2dup get-last-peek nil? if
335         2drop 2dup read-char
336         2dup 2rot set-last-peek
337     else
338         2swap 2drop
339     then
340 ;
341
342 variable read-line-buffer-span
343 variable read-line-buffer-offset
344
345 ( Hack to save original read-line while we transition to new one. )
346 : orig-read-line immediate
347     ['] read-line , ;
348
349 : read-line ( port -- string )
350
351     2dup get-last-peek
352     nil? if
353         2drop
354         0 read-line-buffer-offset !
355     else
356         2over nil 2swap set-last-peek
357         2dup drop '\n' = if
358             2drop nil nil cons exit
359         else
360             drop pad !
361             1 read-line-buffer-offset !
362         then
363     then
364
365     2dup console-i/o-port obj@ objeq? if
366         2drop
367         pad read-line-buffer-offset @ + 200 expect cr
368         span @ read-line-buffer-offset @ + read-line-buffer-span !
369     else
370         pad read-line-buffer-offset @ + 200 2over fileport>fid orig-read-line
371         drop swap read-line-buffer-offset @ + read-line-buffer-span !
372     then
373
374     nil
375     
376     begin
377         read-line-buffer-span @ 0>
378     while
379         pad read-line-buffer-span @ 1- + @ character-type 2swap cons
380         -1 read-line-buffer-span +!
381     repeat
382
383     nil? if
384         nil cons drop string-type
385     else
386         drop string-type
387     then
388 ;
389
390 : read-port ( fileport -- obj )
391     current-input-port obj!
392     read ;
393
394 : read-console ( -- obj )
395     console-i/o-port obj@ read-port ;
396
397 \ }}}
398
399 \ ---- Environments ---- {{{
400
401 : enclosing-env ( env -- env )
402     cdr ;
403
404 : first-frame ( env -- frame )
405     car ;
406
407 : make-frame ( vars vals -- frame )
408     cons ;
409
410 : frame-vars ( frame -- vars )
411     car ;
412
413 : frame-vals ( frame -- vals )
414     cdr ;
415
416 : add-binding ( var val frame -- )
417     2swap 2over frame-vals cons
418     2over set-cdr!
419     2swap 2over frame-vars cons
420     2swap set-car!
421 ;
422
423 : extend-env ( vars vals env -- env )
424     >R >R
425     make-frame
426     R> R>
427     cons
428 ;
429
430 objvar vars
431 objvar vals
432
433 : get-vars-vals-frame ( var frame -- bool )
434     2dup frame-vars vars obj!
435     frame-vals vals obj!
436
437     begin
438         vars obj@ nil objeq? false =
439     while
440         2dup vars obj@ car objeq? if
441             2drop true
442             exit
443         then
444
445         vars obj@ cdr vars obj!
446         vals obj@ cdr vals obj!
447     repeat
448
449     2drop false
450 ;
451
452 : get-vars-vals ( var env -- vars? vals? bool )
453
454     begin
455         nil? false =
456     while
457         2over 2over first-frame
458         get-vars-vals-frame if
459             2drop 2drop
460             vars obj@ vals obj@ true
461             exit
462         then
463
464         enclosing-env
465     repeat
466
467     2drop 2drop
468     false
469 ;
470
471 hide vars
472 hide vals
473
474 : lookup-var ( var env -- val )
475     get-vars-vals if
476         2swap 2drop car
477     else
478         recoverable-exception throw" Tried to read unbound variable."
479     then
480 ;
481
482 : set-var ( var val env -- )
483     >R >R 2swap R> R> ( val var env )
484     get-vars-vals if
485         2swap 2drop ( val vals )
486         set-car!
487     else
488         recoverable-exception throw" Tried to set unbound variable."
489     then
490 ;
491
492 objvar env
493
494 : define-var ( var val env -- )
495     env obj! 
496
497     2over env obj@ ( var val var env )
498     get-vars-vals if
499         2swap 2drop ( var val vals )
500         set-car!
501         2drop
502     else
503         env obj@
504         first-frame ( var val frame )
505         add-binding
506     then
507 ;
508
509 hide env
510
511 : make-procedure ( params body env -- proc )
512     nil
513     cons cons cons
514     drop compound-proc-type
515 ;
516
517 objvar global-env
518 nil nil nil extend-env
519 global-env obj!
520
521 \ }}}
522
523 \ ---- Primitives ---- {{{
524
525 : make-primitive ( cfa -- )
526     bl word
527     count
528
529     cstr>charlist
530     charlist>symbol
531   
532     rot primitive-proc-type ( var prim )
533     global-env obj@ define-var
534 ;
535
536 : ensure-arg-count ( args n -- )
537     dup 0= if
538         drop nil objeq? false = if
539             recoverable-exception throw" Too many arguments for primitive procedure."
540         then
541     else
542         -rot nil? if
543             recoverable-exception throw" Too few arguments for primitive procedure."
544         then
545         
546         cdr rot 1- recurse
547     then
548 ;
549
550 : ensure-arg-type-and-count ( tn tn-1 ... t2 t1 args n -- )
551     dup 0= if
552         drop nil objeq? false = if
553             recoverable-exception throw" Too many arguments for primitive procedure."
554         then
555     else
556         -rot nil? if
557             recoverable-exception throw" Too few arguments for primitive procedure."
558         then
559
560         2dup cdr 2swap car ( ... t1 n args' arg1 )
561         2rot 1- swap 2swap rot ( ... args' n-1 arg1 t1 )
562         istype? false = if
563             recoverable-exception throw" Incorrect type for primitive procedure."
564         then
565
566         2drop recurse
567     then
568
569 ;
570
571 : push-args-to-stack ( args -- arg1 arg2 ... argn )
572     begin
573         nil? false =
574     while
575         2dup car 2swap cdr
576     repeat
577
578     2drop
579 ;
580
581 : add-fa-checks ( cfa n -- cfa' )
582     here current @ 1+ dup @ , !
583     0 ,
584     here -rot
585     docol ,
586     ['] 2dup , ['] lit , , ['] ensure-arg-count ,
587     ['] push-args-to-stack ,
588     ['] lit , , ['] execute ,
589     ['] exit ,
590 ;
591
592 : add-fa-type-checks ( cfa t1 t2 ... tn n -- cfa' )
593     here current @ 1+ dup @ , !
594     0 ,
595     here >R
596     docol ,
597     ['] 2dup ,
598     ['] >R , ['] >R ,
599
600     dup ( cfa t1 t2 ... tn n m )
601     
602     begin
603         ?dup 0>
604     while
605         rot ['] lit , , ( cfa t1 t2 ... tn-1 n m )
606         1-
607     repeat
608
609     ['] R> , ['] R> ,
610
611     ['] lit , , ['] ensure-arg-type-and-count ,
612
613     ['] push-args-to-stack ,
614     ['] lit , , ['] execute ,
615     ['] exit ,
616
617     R>
618 ;
619
620 : make-fa-primitive ( cfa n -- )
621     add-fa-checks make-primitive ;
622
623 : make-fa-type-primitive ( cfa t1 t2 ... tn n -- )
624     add-fa-type-checks make-primitive ;
625
626 : arg-type-error
627             bold fg red ." Incorrect argument type." reset-term cr
628             abort
629 ;
630
631 : ensure-arg-type ( arg type -- arg )
632     istype? false = if
633         recoverable-exception throw" Incorrect argument type for primitive procedure."
634     then
635 ;
636
637
638 \ }}}
639
640 \ ---- Macros ---- {{{
641
642 objvar macro-table
643
644 ( Look up macro in macro table. Returns nil if
645   no macro is found. )
646 : lookup-macro ( name_symbol -- proc )
647     macro-table obj@
648
649     begin
650         nil? false =
651     while
652         2over 2over
653         car car objeq? if
654             2swap 2drop
655             car cdr
656             exit
657         then
658
659         cdr
660     repeat
661
662     2swap 2drop
663 ;
664
665 : make-macro ( name_symbol params body env -- )
666     make-procedure
667
668     2swap ( proc name_symbol )
669
670     macro-table obj@
671
672     begin
673         nil? false =
674     while
675         2over 2over ( proc name table name table )
676         car car objeq? if
677             2swap 2drop ( proc table )
678             car ( proc entry )
679             set-cdr!
680             exit
681         then
682
683         cdr
684     repeat
685
686     2drop
687
688     2swap cons
689     macro-table obj@ cons
690     macro-table obj!
691 ;
692
693 \ }}}
694
695 \ ---- Read ---- {{{
696
697 variable parse-idx
698 variable stored-parse-idx
699 create parse-str 161 allot
700 variable parse-str-span
701
702 create parse-idx-stack 10 allot 
703 variable parse-idx-sp
704 parse-idx-stack parse-idx-sp !
705
706 : push-parse-idx
707     parse-idx @ parse-idx-sp @ !
708     1 parse-idx-sp +!
709 ;
710
711 : pop-parse-idx
712     parse-idx-sp @ parse-idx-stack <= abort" Parse index stack underflow."
713
714     1 parse-idx-sp -!
715
716     parse-idx-sp @ @ parse-idx ! ;
717
718
719 : append-newline
720     '\n' parse-str parse-str-span @ + !
721     1 parse-str-span +! ;
722
723 : append-eof
724     4 parse-str parse-str-span @ + !
725     1 parse-str-span +!  ;
726
727 : empty-parse-str
728     0 parse-str-span !
729     0 parse-idx ! ;
730
731 : getline
732     current-input-port obj@ console-i/o-port obj@ objeq? if
733         parse-str 160 expect cr
734         span @ parse-str-span !
735     else
736         parse-str 160 current-input-port obj@ fileport>fid orig-read-line
737         drop swap parse-str-span !
738
739         parse-str-span @ 0= and if append-eof then
740     then
741     append-newline
742     0 parse-idx ! ;
743
744 : inc-parse-idx
745     1 parse-idx +! ;
746
747 : dec-parse-idx
748     1 parse-idx -! ;
749
750 : charavailable? ( -- bool )
751     parse-str-span @ parse-idx @ > ;
752
753 : nextchar ( -- char )
754     charavailable? false = if getline then
755     parse-str parse-idx @ + @ ;
756
757 : '\t' 9 ;
758 : whitespace? ( -- bool )
759     nextchar BL = 
760     nextchar '\n' =
761     nextchar '\t' =
762     or or ;
763
764 : EOF 4 ; 
765 : eof? ( -- bool )
766     nextchar EOF = ;
767
768 : delim? ( -- bool )
769     whitespace?
770     nextchar [char] ( = or
771     nextchar [char] ) = or
772 ;
773
774 : commentstart? ( -- bool )
775     nextchar [char] ; = ;
776
777 : eatspaces
778
779     false \ Indicates whether or not we're eating a comment
780
781     begin
782         dup whitespace? or commentstart? or
783     while
784         dup nextchar '\n' = and if
785             invert \ Stop eating comment
786         else
787             dup false = commentstart? and if   
788                 invert \ Begin eating comment
789             then
790         then
791
792         inc-parse-idx
793     repeat
794     drop
795 ;
796
797 : digit? ( -- bool )
798     nextchar [char] 0 >=
799     nextchar [char] 9 <=
800     and ;
801
802 : minus? ( -- bool )
803     nextchar [char] - = ;
804
805 : plus? ( -- bool )
806     nextchar [char] + = ;
807
808 : fixnum? ( -- bool )
809     minus? plus? or if
810         inc-parse-idx
811
812         delim? if
813             dec-parse-idx
814             false exit
815         else
816             dec-parse-idx
817         then
818     else
819         digit? false = if
820             false exit
821         then
822     then
823
824     push-parse-idx
825     inc-parse-idx
826
827     begin digit? while
828         inc-parse-idx
829     repeat
830
831     delim? pop-parse-idx
832 ;
833
834 : flonum? ( -- bool )
835     push-parse-idx
836
837     minus? plus? or if
838         inc-parse-idx
839     then
840
841     \ Record starting parse idx:
842     \ Want to detect whether any characters (following +/-) were eaten.
843     parse-idx @
844
845     begin digit? while
846             inc-parse-idx
847     repeat
848
849     [char] . nextchar = if
850         inc-parse-idx
851         begin digit? while
852                 inc-parse-idx
853         repeat
854     then
855
856     [char] e nextchar = [char] E nextchar = or if
857         inc-parse-idx
858
859         minus? plus? or if
860             inc-parse-idx
861         then
862
863         digit? invert if
864             drop pop-parse-idx false exit
865         then
866
867         begin digit? while
868                 inc-parse-idx
869         repeat
870     then
871
872     \ This is a real number if characters were
873     \ eaten and the next characer is a delimiter.
874     parse-idx @ < delim? and
875
876     pop-parse-idx
877 ;
878
879 : ratnum? ( -- bool )
880     push-parse-idx
881
882     minus? plus? or if
883         inc-parse-idx
884     then
885
886     digit? invert if
887         pop-parse-idx false exit
888     else
889         inc-parse-idx
890     then
891
892     begin digit? while
893         inc-parse-idx
894     repeat
895
896     [char] / nextchar <> if
897         pop-parse-idx false exit
898     else
899         inc-parse-idx
900     then
901
902     digit? invert if
903         pop-parse-idx false exit
904     else
905         inc-parse-idx
906     then
907
908     begin digit? while
909         inc-parse-idx
910     repeat
911
912     delim? pop-parse-idx
913 ;
914
915 : boolean? ( -- bool )
916     nextchar [char] # <> if false exit then
917
918     push-parse-idx
919     inc-parse-idx
920
921     nextchar [char] t <>
922     nextchar [char] f <>
923     and if pop-parse-idx false exit then
924
925     inc-parse-idx
926     delim? if
927         pop-parse-idx
928         true
929     else
930         pop-parse-idx
931         false
932     then
933 ;
934
935 : str-equiv? ( str -- bool )
936
937     push-parse-idx
938
939     true -rot
940
941     swap dup rot + swap
942
943     do
944         i @ nextchar <> if
945             drop false
946             leave
947         then
948
949         inc-parse-idx
950     loop
951
952     delim? false = if drop false then
953
954     pop-parse-idx
955 ;
956
957 : character? ( -- bool )
958     nextchar [char] # <> if false exit then
959
960     push-parse-idx
961     inc-parse-idx
962
963     nextchar [char] \ <> if pop-parse-idx false exit then
964
965     inc-parse-idx
966
967     S" newline" str-equiv? if pop-parse-idx true exit then
968     S" space" str-equiv? if pop-parse-idx true exit then
969     S" tab" str-equiv? if pop-parse-idx true exit then
970
971     charavailable? false = if pop-parse-idx false exit then
972
973     pop-parse-idx true
974 ;
975
976 : pair? ( -- bool )
977     nextchar [char] ( = ;
978
979 : string? ( -- bool )
980     nextchar [char] " = ;
981
982 : readfixnum ( -- fixnum )
983     plus? minus? or if
984         minus?
985         inc-parse-idx
986     else
987         false
988     then
989
990     0
991
992     begin digit? while
993         10 * nextchar [char] 0 - +
994         inc-parse-idx
995     repeat
996
997     swap if negate then
998
999     fixnum-type
1000 ;
1001
1002 : readflonum ( -- flonum )
1003     readfixnum drop
1004     dup 0< swap abs i->f
1005
1006     [char] . nextchar = if
1007         inc-parse-idx
1008
1009         10.0 ( f exp )
1010
1011         begin digit? while
1012             nextchar [char] 0 - i->f ( f exp d )
1013             over f/ rot f+ ( exp f' )
1014             swap 10.0 f* ( f' exp' )
1015             inc-parse-idx
1016         repeat
1017
1018         drop
1019     then
1020
1021     [char] e nextchar = [char] E nextchar = or if
1022         inc-parse-idx
1023         10.0
1024         readfixnum drop i->f
1025         f^ f*
1026     then
1027
1028     swap if
1029         -1.0 f*
1030     then
1031
1032     flonum-type
1033 ;
1034
1035 : make-rational ( fixnum fixnum -- ratnum|fixnum )
1036     drop swap drop
1037     simplify
1038
1039     dup 1 = if
1040         drop fixnum-type
1041     else
1042         fixnum-type swap fixnum-type
1043         cons drop ratnum-type
1044     then
1045 ;
1046
1047 : readratnum ( -- ratnum )
1048     readfixnum inc-parse-idx readfixnum
1049     make-rational
1050 ;
1051
1052 : readbool ( -- bool-obj )
1053     inc-parse-idx
1054     
1055     nextchar [char] f = if
1056         false
1057     else
1058         true
1059     then
1060
1061     inc-parse-idx
1062
1063     boolean-type
1064 ;
1065
1066 : readchar ( -- char-obj )
1067     inc-parse-idx
1068     inc-parse-idx
1069
1070     S" newline" str-equiv? if 7 parse-idx +! '\n' character-type exit then
1071     S" space" str-equiv? if 5 parse-idx +! bl character-type exit then
1072     S" tab" str-equiv? if 3 parse-idx +! 9 character-type exit then
1073
1074     nextchar character-type
1075
1076     inc-parse-idx
1077 ;
1078
1079 : readstring ( -- charlist )
1080
1081     nil nil
1082
1083     begin
1084         nextchar [char] " <>
1085     while
1086         nextchar [char] \ = if
1087             inc-parse-idx
1088             nextchar case
1089                 [char] n of '\n' endof
1090                 [char] " of [char] " endof
1091                 [char] \
1092             endcase
1093         else
1094             nextchar
1095         then
1096         inc-parse-idx character-type
1097         nil cons
1098
1099         ( firstchar prevchar thischar )
1100
1101         2swap nil? if
1102             2drop 2swap 2drop 2dup  ( thischar thischar )
1103         else
1104             ( firstchar thischar prevchar )
1105             2over 2swap  set-cdr! ( firstchar thischar )
1106         then
1107     repeat
1108
1109     \ Discard previous character
1110     2drop
1111
1112     inc-parse-idx
1113     delim? false = if
1114         bold fg red
1115         ." No delimiter following right double quote. Aborting." cr
1116         reset-term abort
1117     then
1118
1119     dec-parse-idx
1120
1121     nil? if
1122         nil cons
1123     then
1124     drop string-type
1125 ;
1126
1127 : readsymbol ( -- charlist )
1128     delim? if nil exit then
1129
1130     nextchar inc-parse-idx character-type
1131
1132     recurse
1133
1134     cons
1135 ;
1136
1137 : readpair ( -- pairobj )
1138     eatspaces
1139
1140     \ Empty lists
1141     nextchar [char] ) = if
1142         inc-parse-idx
1143
1144         delim? false = if
1145             bold fg red
1146             ." No delimiter following right paren. Aborting." cr
1147             reset-term abort
1148         then
1149
1150         dec-parse-idx
1151
1152         0 nil-type exit
1153     then
1154
1155     \ Read first pair element
1156     read
1157
1158     \ Pairs
1159     eatspaces
1160     nextchar [char] . = if
1161         inc-parse-idx
1162
1163         delim? false = if
1164             bold fg red
1165             ." No delimiter following '.'. Aborting." cr
1166             reset-term abort
1167         then
1168
1169         eatspaces read
1170     else
1171         recurse
1172     then
1173
1174     eatspaces
1175
1176     cons
1177 ;
1178
1179 \ Parse a scheme expression
1180 :noname ( -- obj )
1181
1182     eatspaces
1183
1184     fixnum? if
1185         readfixnum
1186         exit
1187     then
1188
1189     flonum? if
1190         readflonum
1191         exit
1192     then
1193
1194     ratnum? if
1195         readratnum
1196         exit
1197     then
1198
1199     boolean? if
1200         readbool
1201         exit
1202     then
1203
1204     character? if
1205         readchar
1206         exit
1207     then
1208
1209     string? if
1210         inc-parse-idx
1211
1212         readstring
1213
1214         nextchar [char] " <> if
1215             bold red ." Missing closing double-quote." reset-term cr
1216             abort
1217         then
1218
1219         inc-parse-idx
1220
1221         exit
1222     then
1223
1224     pair? if
1225         inc-parse-idx
1226
1227         eatspaces
1228
1229         readpair
1230
1231         eatspaces
1232
1233         nextchar [char] ) <> if
1234             bold red ." Missing closing paren." reset-term cr
1235             abort
1236         then
1237
1238         inc-parse-idx
1239
1240         exit
1241     then
1242
1243     nextchar [char] ' = if
1244         inc-parse-idx
1245         quote-symbol recurse nil cons cons exit
1246     then
1247
1248     nextchar [char] ` = if
1249         inc-parse-idx
1250         quasiquote-symbol recurse nil cons cons exit
1251     then
1252
1253     nextchar [char] , = if
1254         inc-parse-idx
1255         nextchar [char] @ = if
1256             inc-parse-idx
1257             unquote-splicing-symbol recurse nil cons cons exit
1258         else
1259             unquote-symbol recurse nil cons cons exit
1260         then
1261     then
1262
1263     eof? if
1264         EOF character-type
1265         inc-parse-idx
1266         exit
1267     then
1268
1269     \ Anything else is parsed as a symbol
1270     readsymbol charlist>symbol
1271
1272     \ Replace Î» with lambda
1273     2dup Î»-symbol objeq? if
1274         2drop lambda-symbol
1275     then
1276     
1277
1278 ; is read
1279
1280 \ }}}
1281
1282 \ ---- Eval ---- {{{
1283
1284 : self-evaluating? ( obj -- obj bool )
1285     boolean-type istype? if true exit then
1286     fixnum-type istype? if true exit then
1287     flonum-type istype? if true exit then
1288     ratnum-type istype? if true exit then
1289     character-type istype? if true exit then
1290     string-type istype? if true exit then
1291     nil-type istype? if true exit then
1292     none-type istype? if true exit then
1293
1294     false
1295 ;
1296
1297 : tagged-list? ( obj tag-obj -- obj bool )
1298     2over 
1299     pair-type istype? false = if
1300         2drop 2drop false
1301     else
1302         car objeq?
1303     then ;
1304
1305 : quote? ( obj -- obj bool )
1306     quote-symbol tagged-list?  ;
1307
1308 : quote-body ( quote-obj -- quote-body-obj )
1309     cdr car ;
1310
1311 : quasiquote? ( obj -- obj bool )
1312     quasiquote-symbol tagged-list? ;
1313
1314 : unquote? ( obj -- obj bool )
1315     unquote-symbol tagged-list? ;
1316
1317 : unquote-splicing? ( obj -- obj bool )
1318     unquote-splicing-symbol tagged-list? ;
1319
1320 : eval-unquote ( env obj -- res )
1321     cdr ( env args )
1322
1323     nil? if
1324         recoverable-exception throw" no arguments to unquote."
1325     then
1326
1327     2dup cdr
1328     nil? false = if
1329         recoverable-exception throw" too many arguments to unquote."
1330     then
1331
1332     2drop car 2swap eval
1333 ;
1334
1335 ( Create a new list from elements of l1 consed on to l2 )
1336 : join-lists ( l2 l1 -- l3 )
1337     nil? if 2drop exit then
1338
1339     2dup car
1340     -2rot cdr
1341     recurse cons
1342 ;
1343
1344 defer eval-quasiquote-item
1345 : eval-quasiquote-pair ( env obj -- res )
1346     2over 2over ( env obj env obj )
1347
1348     cdr eval-quasiquote-item
1349
1350     -2rot car ( cdritem env objcar )
1351
1352     unquote-splicing? if
1353         eval-unquote ( cdritems caritem )
1354
1355         2swap nil? if
1356             2drop
1357         else
1358             2swap join-lists
1359         then
1360     else
1361         eval-quasiquote-item ( cdritems caritem )
1362         2swap cons
1363     then
1364
1365 ;
1366
1367 :noname ( env obj )
1368     nil? if
1369         2swap 2drop exit
1370     then
1371
1372     unquote? if
1373         eval-unquote exit
1374     then
1375
1376     pair-type istype? if
1377         eval-quasiquote-pair exit
1378     then
1379
1380     2swap 2drop
1381 ; is eval-quasiquote-item
1382
1383 : eval-quasiquote ( obj env -- res )
1384     2swap cdr ( env args )
1385
1386     nil? if
1387         recoverable-exception throw" no arguments to quasiquote."
1388     then
1389
1390     2dup cdr ( env args args-cdr )
1391     nil? false = if
1392         recoverable-exception throw" too many arguments to quasiquote."
1393     then
1394
1395     2drop car ( env arg )
1396
1397     eval-quasiquote-item
1398 ;
1399
1400 : variable? ( obj -- obj bool )
1401     symbol-type istype? ;
1402
1403 : definition? ( obj -- obj bool )
1404     define-symbol tagged-list? ;
1405
1406 : make-lambda ( params body -- lambda-exp )
1407     lambda-symbol -2rot cons cons ;
1408
1409 ( Handles iterative expansion of defines in
1410   terms of nested lambdas. Most Schemes only
1411   handle one iteration of expansion! )
1412 : definition-var-val ( obj -- var val )
1413
1414     cdr 2dup cdr 2swap car ( val var )
1415
1416     begin
1417         symbol-type istype? false =
1418     while
1419         2dup cdr 2swap car ( val formals var' )
1420         -2rot 2swap ( var' formals val )
1421         make-lambda nil cons ( var' val' )
1422         2swap ( val' var' )
1423     repeat
1424
1425     2swap car
1426 ;
1427
1428 : eval-definition ( obj env -- res )
1429     2dup 2rot ( env env obj )
1430     definition-var-val ( env env var val )
1431     2rot eval  ( env var val )
1432
1433     2rot ( var val env )
1434     define-var
1435
1436     ok-symbol
1437 ;
1438
1439 : assignment? ( obj -- obj bool )
1440     set!-symbol tagged-list? ;
1441
1442 : assignment-var ( obj -- var )
1443     cdr car ;
1444     
1445 : assignment-val ( obj -- val )
1446     cdr cdr car ;
1447
1448 : eval-assignment ( obj env -- res )
1449     2swap 
1450     2over 2over ( env obj env obj )
1451     assignment-val 2swap ( env obj valexp env )
1452     eval  ( env obj val )
1453     
1454     2swap assignment-var 2swap ( env var val )
1455
1456     2rot ( var val env )
1457     set-var
1458
1459     ok-symbol
1460 ;
1461
1462 : macro-definition? ( obj -- obj bool )
1463     define-macro-symbol tagged-list? ;
1464
1465 : macro-definition-name ( exp -- mname )
1466     cdr car car ;
1467
1468 : macro-definition-params ( exp -- params )
1469     cdr car cdr ;
1470
1471 : macro-definition-body ( exp -- body )
1472     cdr cdr ;
1473
1474 objvar env
1475 : eval-define-macro ( obj env -- res )
1476     env obj!
1477
1478     2dup macro-definition-name 2swap ( name obj )
1479     2dup macro-definition-params 2swap ( name params obj )
1480     macro-definition-body ( name params body )
1481
1482     env obj@ ( name params body env )
1483
1484     make-macro
1485
1486     ok-symbol
1487 ;
1488 hide env
1489
1490 : if? ( obj -- obj bool )
1491     if-symbol tagged-list? ;
1492
1493 : if-predicate ( ifobj -- pred )
1494     cdr car ;
1495
1496 : if-consequent ( ifobj -- conseq )
1497     cdr cdr car ;
1498
1499 : if-alternative ( ifobj -- alt|none )
1500     cdr cdr cdr
1501     nil? if
1502         2drop none
1503     else
1504         car
1505     then ;
1506
1507 : false? ( boolobj -- boolean )
1508     boolean-type istype? if
1509         false boolean-type objeq?
1510     else
1511         2drop false
1512     then
1513 ;
1514
1515 : true? ( boolobj -- bool )
1516     false? invert ;
1517
1518 : lambda? ( obj -- obj bool )
1519     lambda-symbol tagged-list? ;
1520
1521 : lambda-parameters ( obj -- params )
1522     cdr car ;
1523
1524 : lambda-body ( obj -- body )
1525     cdr cdr ;
1526
1527 : begin? ( obj -- obj bool )
1528     begin-symbol tagged-list? ;
1529
1530 : begin-actions ( obj -- actions )
1531     cdr ;
1532
1533 : eval-sequence ( explist env -- finalexp env )
1534     ( Evaluates all bar the final expressions in
1535       an an expression list. The final expression
1536       is returned to allow for tail optimization. )
1537
1538     2swap ( env explist )
1539
1540     \ Abort on empty list
1541     nil? if
1542         2drop none
1543         2swap exit
1544     then
1545
1546     begin
1547         2dup cdr ( env explist nextexplist )
1548         nil? false =
1549     while
1550         -2rot car 2over ( nextexplist env exp env )
1551         eval
1552         2drop \ discard result
1553         2swap ( env nextexplist )
1554     repeat
1555
1556     2drop car 2swap ( finalexp env )
1557 ;
1558
1559 : application? ( obj -- obj bool )
1560     pair-type istype? ;
1561
1562 : operator ( obj -- operator )
1563     car ;
1564
1565 : operands ( obj -- operands )
1566     cdr ;
1567
1568 : nooperands? ( operands -- bool )
1569     nil objeq? ;
1570
1571 : first-operand ( operands -- operand )
1572     car ;
1573
1574 : rest-operands ( operands -- other-operands )
1575     cdr ;
1576
1577 : list-of-vals ( args env -- vals )
1578     2swap
1579
1580     2dup nooperands? if
1581         2swap 2drop
1582     else
1583         2over 2over first-operand 2swap eval
1584         -2rot rest-operands 2swap recurse
1585         cons
1586     then
1587 ;
1588
1589 : procedure-params ( proc -- params )
1590     drop pair-type car ;
1591
1592 : procedure-body ( proc -- body )
1593     drop pair-type cdr car ;
1594
1595 : procedure-env ( proc -- body )
1596     drop pair-type cdr cdr car ;
1597
1598 ( Ensure terminating symbol arg name is handled
1599   specially to allow for variadic procedures. )
1600 : flatten-proc-args ( argvals argnames -- argvals' argnames' )
1601     nil? if
1602         2over nil? false = if
1603             recoverable-exception throw" Too many arguments for compound procedure."
1604         else
1605             2drop
1606         then
1607         exit
1608     then
1609
1610     symbol-type istype? if
1611         nil cons
1612         2swap
1613         nil cons
1614         2swap
1615         exit
1616     then
1617
1618     2over
1619     nil? if
1620         recoverable-exception throw" Too few arguments for compound procedure."
1621     else
1622         cdr
1623     then
1624
1625     2over cdr
1626
1627     recurse ( argvals argnames argvals'' argnames'' )
1628     2rot car 2swap cons  ( argvals argvals'' argnames' )
1629     2rot car 2rot cons ( argnames' argvals' )
1630     2swap
1631 ;
1632
1633 : apply ( proc argvals -- result )
1634         2swap dup case
1635             primitive-proc-type of
1636                 drop execute     
1637             endof
1638
1639             compound-proc-type of
1640                 2dup procedure-body ( argvals proc body )
1641                 -2rot 2dup procedure-params ( body argvals proc argnames )
1642                 -2rot procedure-env ( body argnames argvals procenv )
1643
1644                 -2rot 2swap
1645                 flatten-proc-args
1646                 2swap 2rot
1647
1648                 extend-env ( body env )
1649
1650                 eval-sequence
1651
1652                 R> drop ['] eval goto-deferred  \ Tail call optimization
1653             endof
1654
1655             recoverable-exception throw" Object not applicable."
1656         endcase
1657 ;
1658
1659 ( Simply evaluates the given procedure with expbody as its argument. )
1660 : macro-expand ( proc expbody -- result )
1661     2swap
1662     2dup procedure-body ( expbody proc procbody )
1663     -2rot 2dup procedure-params ( procbody expbody proc argnames )
1664     -2rot procedure-env ( procbody argnames expbody procenv )
1665     
1666     -2rot 2swap
1667     flatten-proc-args
1668     2swap 2rot
1669
1670     extend-env eval-sequence eval
1671 ;
1672
1673 :noname ( obj env -- result )
1674     2swap
1675
1676     self-evaluating? if
1677         2swap 2drop
1678         exit
1679     then
1680
1681     quote? if
1682         quote-body
1683         2swap 2drop
1684         exit
1685     then
1686
1687     quasiquote? if
1688         2swap eval-quasiquote
1689         exit
1690     then
1691
1692     variable? if
1693         2swap lookup-var
1694         exit
1695     then
1696
1697     definition? if
1698         2swap eval-definition
1699         exit
1700     then
1701
1702     assignment? if
1703         2swap eval-assignment
1704         exit
1705     then
1706
1707     macro-definition? if
1708         2swap eval-define-macro
1709         exit
1710     then
1711
1712     if? if
1713         2over 2over
1714         if-predicate
1715         2swap eval 
1716
1717         true? if
1718             if-consequent
1719         else
1720             if-alternative
1721         then
1722
1723         2swap
1724         ['] eval goto-deferred
1725     then
1726
1727     lambda? if
1728         2dup lambda-parameters
1729         2swap lambda-body
1730         2rot make-procedure
1731         exit
1732     then
1733
1734     begin? if
1735         begin-actions 2swap
1736         eval-sequence
1737         ['] eval goto-deferred
1738     then
1739
1740     application? if
1741
1742         2over 2over ( env exp env exp )
1743         operator ( env exp env opname )
1744
1745         2dup lookup-macro nil? false = if
1746              \ Macro function evaluation
1747
1748             ( env exp env opname mproc )
1749             2swap 2drop -2rot 2drop cdr ( env mproc body )
1750
1751             macro-expand
1752
1753             2swap
1754             ['] eval goto-deferred
1755         else
1756            \ Regular function application
1757
1758             2drop ( env exp env opname )
1759
1760             2swap eval ( env exp proc )
1761
1762             -2rot ( proc env exp )
1763             operands 2swap ( proc operands env )
1764             list-of-vals ( proc argvals )
1765
1766             apply
1767             exit
1768         then
1769     then
1770
1771     recoverable-exception throw" Tried to evaluate object with unknown type."
1772 ; is eval
1773
1774 \ }}}
1775
1776 \ ---- Print ---- {{{
1777
1778 : printfixnum ( fixnum -- ) drop 0 .R ;
1779
1780 : printflonum ( flonum -- ) drop f. ;
1781
1782 : printratnum ( ratnum -- )
1783     drop pair-type 2dup
1784     car print ." /" cdr print
1785 ;
1786
1787 : printbool ( bool -- )
1788     drop if
1789         ." #t"
1790     else
1791         ." #f"
1792     then
1793 ;
1794
1795 : printchar ( charobj -- )
1796     drop
1797     case
1798         9 of ." #\tab" endof
1799         bl of ." #\space" endof
1800         '\n' of ." #\newline" endof
1801         
1802         dup ." #\" emit
1803     endcase
1804 ;
1805
1806 : (printstring) ( stringobj -- )
1807     nil? if 2drop exit then
1808
1809     2dup car drop dup
1810     case
1811         '\n' of ." \n" drop endof
1812         [char] \ of ." \\" drop endof
1813         [char] " of [char] \ emit [char] " emit drop endof
1814         emit
1815     endcase
1816
1817     cdr recurse
1818 ;
1819 : printstring ( stringobj -- )
1820     [char] " emit
1821     (printstring)
1822     [char] " emit ;
1823
1824 : printsymbol ( symbolobj -- )
1825     nil-type istype? if 2drop exit then
1826
1827     2dup car drop emit
1828     cdr recurse
1829 ;
1830
1831 : printnil ( nilobj -- )
1832     2drop ." ()" ;
1833
1834 : printpair ( pairobj -- )
1835     2dup
1836     car print
1837     cdr
1838     nil-type istype? if 2drop exit then
1839     pair-type istype? if space recurse exit then
1840     ."  . " print
1841 ;
1842
1843 : printprim ( primobj -- )
1844     2drop ." <primitive procedure>" ;
1845
1846 : printcomp ( primobj -- )
1847     2drop ." <compound procedure>" ;
1848
1849 : printnone ( noneobj -- )
1850     2drop ." Unspecified return value" ;
1851
1852 : printport ( port -- )
1853     2drop ." <port>" ;
1854
1855 :noname ( obj -- )
1856     fixnum-type istype? if printfixnum exit then
1857     flonum-type istype? if printflonum exit then
1858     ratnum-type istype? if printratnum exit then
1859     boolean-type istype? if printbool exit then
1860     character-type istype? if printchar exit then
1861     string-type istype? if printstring exit then
1862     symbol-type istype? if printsymbol exit then
1863     nil-type istype? if printnil exit then
1864     pair-type istype? if ." (" printpair ." )" exit then
1865     primitive-proc-type istype? if printprim exit then
1866     compound-proc-type istype? if printcomp exit then
1867     none-type istype? if printnone exit then
1868     port-type istype? if printport exit then
1869
1870     recoverable-exception throw" Tried to print object with unknown type."
1871 ; is print
1872
1873 \ }}}
1874
1875 \ ---- Garbage Collection ---- {{{
1876
1877 variable gc-enabled
1878 false gc-enabled !
1879
1880 variable gc-stack-depth
1881
1882 : enable-gc
1883     depth gc-stack-depth !
1884     true gc-enabled ! ;
1885
1886 : disable-gc
1887     false gc-enabled ! ;
1888
1889 : gc-enabled?
1890     gc-enabled @ ;
1891
1892 : pairlike? ( obj -- obj bool )
1893     pair-type istype? if true exit then
1894     string-type istype? if true exit then
1895     symbol-type istype? if true exit then
1896     compound-proc-type istype? if true exit then
1897     port-type istype? if true exit then
1898
1899     false
1900 ;
1901
1902 : pairlike-marked? ( obj -- obj bool )
1903     over nextfrees + @ 0=
1904 ;
1905
1906 : mark-pairlike ( obj -- obj )
1907         over nextfrees + 0 swap !
1908 ;
1909
1910 : gc-unmark ( -- )
1911     scheme-memsize 0 do
1912         1 nextfrees i + !
1913     loop
1914 ;
1915
1916 : gc-mark-obj ( obj -- )
1917
1918     pairlike? invert if 2drop exit then
1919     pairlike-marked? if 2drop exit then
1920
1921     mark-pairlike
1922
1923     drop pair-type 2dup
1924
1925     car recurse
1926     cdr recurse
1927 ;
1928
1929 : gc-sweep
1930     scheme-memsize nextfree !
1931     0 scheme-memsize 1- do
1932         nextfrees i + @ 0<> if
1933             nextfree @ nextfrees i + !
1934             i nextfree !
1935         then
1936     -1 +loop
1937 ;
1938
1939 \ Following a GC, this gives the amount of free memory
1940 : gc-count-marked
1941     0
1942     scheme-memsize 0 do
1943         nextfrees i + @ 0= if 1+ then
1944     loop
1945 ;
1946
1947 \ Debugging word - helps spot memory that is retained
1948 : gc-zero-unmarked
1949     scheme-memsize 0 do
1950         nextfrees i + @ 0<> if
1951             0 car-cells i + !
1952             0 cdr-cells i + !
1953         then
1954     loop
1955 ;
1956
1957 :noname
1958     \ ." GC! "
1959
1960     gc-unmark
1961
1962     symbol-table obj@ gc-mark-obj
1963     macro-table obj@ gc-mark-obj
1964     console-i/o-port obj@ gc-mark-obj
1965     global-env obj@ gc-mark-obj
1966
1967     depth gc-stack-depth @ do
1968         PSP0 i + 1 + @
1969         PSP0 i + 2 + @
1970
1971         gc-mark-obj
1972     2 +loop
1973
1974     gc-sweep
1975
1976     \ ." (" gc-count-marked . ." pairs marked as used.)" cr
1977 ; is collect-garbage
1978
1979 \ }}}
1980
1981 \ ---- Loading files ---- {{{
1982
1983 : load ( addr n -- finalResult )
1984     open-input-file
1985
1986     empty-parse-str
1987
1988     ok-symbol ( port res )
1989
1990     begin
1991         2over read-port ( port res obj )
1992
1993         2dup EOF character-type objeq? if
1994             2drop 2swap close-port
1995             exit
1996         then
1997
1998         2swap 2drop ( port obj )
1999
2000         global-env obj@ eval ( port res )
2001     again
2002 ;
2003
2004 \ }}}
2005
2006 \ ---- Standard Library ---- {{{
2007
2008     include scheme-primitives.4th
2009
2010     s" scheme-library.scm" load 2drop
2011     
2012 \ }}}
2013
2014 \ ---- REPL ----
2015
2016 ( REPL calls REPL-BODY in a loop until repl-body returns true. )
2017 : repl-body ( -- bool )
2018     cr bold fg green ." > " reset-term
2019
2020     read-console
2021
2022     2dup EOF character-type objeq? if
2023         2drop
2024         bold fg blue ." Moriturus te saluto." reset-term cr
2025         true exit
2026     then
2027
2028     global-env obj@ eval
2029
2030     fg cyan ." ; " print reset-term
2031
2032     false
2033 ;
2034
2035 : repl
2036
2037     empty-parse-str
2038
2039     enable-gc
2040
2041     \ Display welcome message
2042     welcome-symbol nil cons global-env obj@ eval 2drop
2043
2044     begin
2045         ['] repl-body catch
2046         case
2047             recoverable-exception of false endof
2048             unrecoverable-exception of true endof
2049
2050             throw false
2051         endcase
2052     until
2053 ;
2054
2055 forth definitions
2056
2057 \ vim:fdm=marker